{-# LANGUAGE DeriveGeneric #-}
module Terminal.Game.Plane where
import Terminal.Game.Character
import qualified Data.Array as A
import qualified Data.Bifunctor as B
import qualified Data.List.Split as LS
import qualified Data.Tuple as T
import qualified GHC.Generics as G
import qualified System.Console.ANSI as CA
type Coords = (Row, Column)
type Row = Int
type Column = Int
type Dimensions = (Width, Height)
type Width = Int
type Height = Int
type Bold = Bool
type Reversed = Bool
data Cell = CellChar Char Bold
Reversed (Maybe (CA.Color, CA.ColorIntensity))
| Transparent
deriving (Row -> Cell -> ShowS
[Cell] -> ShowS
Cell -> String
forall a.
(Row -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cell] -> ShowS
$cshowList :: [Cell] -> ShowS
show :: Cell -> String
$cshow :: Cell -> String
showsPrec :: Row -> Cell -> ShowS
$cshowsPrec :: Row -> Cell -> ShowS
Show, Cell -> Cell -> Bold
forall a. (a -> a -> Bold) -> (a -> a -> Bold) -> Eq a
/= :: Cell -> Cell -> Bold
$c/= :: Cell -> Cell -> Bold
== :: Cell -> Cell -> Bold
$c== :: Cell -> Cell -> Bold
Eq, Eq Cell
Cell -> Cell -> Bold
Cell -> Cell -> Ordering
Cell -> Cell -> Cell
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bold)
-> (a -> a -> Bold)
-> (a -> a -> Bold)
-> (a -> a -> Bold)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Cell -> Cell -> Cell
$cmin :: Cell -> Cell -> Cell
max :: Cell -> Cell -> Cell
$cmax :: Cell -> Cell -> Cell
>= :: Cell -> Cell -> Bold
$c>= :: Cell -> Cell -> Bold
> :: Cell -> Cell -> Bold
$c> :: Cell -> Cell -> Bold
<= :: Cell -> Cell -> Bold
$c<= :: Cell -> Cell -> Bold
< :: Cell -> Cell -> Bold
$c< :: Cell -> Cell -> Bold
compare :: Cell -> Cell -> Ordering
$ccompare :: Cell -> Cell -> Ordering
Ord, forall x. Rep Cell x -> Cell
forall x. Cell -> Rep Cell x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Cell x -> Cell
$cfrom :: forall x. Cell -> Rep Cell x
G.Generic)
newtype Plane = Plane { Plane -> Array Coords Cell
fromPlane :: A.Array Coords Cell }
deriving (Row -> Plane -> ShowS
[Plane] -> ShowS
Plane -> String
forall a.
(Row -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Plane] -> ShowS
$cshowList :: [Plane] -> ShowS
show :: Plane -> String
$cshow :: Plane -> String
showsPrec :: Row -> Plane -> ShowS
$cshowsPrec :: Row -> Plane -> ShowS
Show, Plane -> Plane -> Bold
forall a. (a -> a -> Bold) -> (a -> a -> Bold) -> Eq a
/= :: Plane -> Plane -> Bold
$c/= :: Plane -> Plane -> Bold
== :: Plane -> Plane -> Bold
$c== :: Plane -> Plane -> Bold
Eq, forall x. Rep Plane x -> Plane
forall x. Plane -> Rep Plane x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Plane x -> Plane
$cfrom :: forall x. Plane -> Rep Plane x
G.Generic)
listPlane :: Coords -> [Cell] -> Plane
listPlane :: Coords -> [Cell] -> Plane
listPlane (Row
r, Row
c) [Cell]
cs = Array Coords Cell -> Plane
Plane forall a b. (a -> b) -> a -> b
$ forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray ((Row
1,Row
1), (Row
r, Row
c)) [Cell]
cs
planeSize :: Plane -> Dimensions
planeSize :: Plane -> Coords
planeSize Plane
p = forall a b. (a, b) -> (b, a)
T.swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall i e. Array i e -> (i, i)
A.bounds (Plane -> Array Coords Cell
fromPlane Plane
p)
assocsPlane :: Plane -> [(Coords, Cell)]
assocsPlane :: Plane -> [(Coords, Cell)]
assocsPlane Plane
p = forall i e. Ix i => Array i e -> [(i, e)]
A.assocs (Plane -> Array Coords Cell
fromPlane Plane
p)
elemsPlane :: Plane -> [Cell]
elemsPlane :: Plane -> [Cell]
elemsPlane Plane
p = forall i e. Array i e -> [e]
A.elems (Plane -> Array Coords Cell
fromPlane Plane
p)
updatePlane :: Plane -> [(Coords, Cell)] -> Plane
updatePlane :: Plane -> [(Coords, Cell)] -> Plane
updatePlane (Plane Array Coords Cell
a) [(Coords, Cell)]
kcs = Array Coords Cell -> Plane
Plane forall a b. (a -> b) -> a -> b
$ Array Coords Cell
a forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
A.// [(Coords, Cell)]
kcs
mapPlane :: (Cell -> Cell) -> Plane -> Plane
mapPlane :: (Cell -> Cell) -> Plane -> Plane
mapPlane Cell -> Cell
f (Plane Array Coords Cell
a) = Array Coords Cell -> Plane
Plane forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cell -> Cell
f Array Coords Cell
a
creaCell :: Char -> Cell
creaCell :: Char -> Cell
creaCell Char
ch = Char -> Bold -> Bold -> Maybe (Color, ColorIntensity) -> Cell
CellChar Char
chm Bold
False Bold
False forall a. Maybe a
Nothing
where
chm :: Char
chm = Char -> Char
win32SafeChar Char
ch
colorCell :: CA.Color -> CA.ColorIntensity -> Cell -> Cell
colorCell :: Color -> ColorIntensity -> Cell -> Cell
colorCell Color
k ColorIntensity
i (CellChar Char
c Bold
b Bold
r Maybe (Color, ColorIntensity)
_) = Char -> Bold -> Bold -> Maybe (Color, ColorIntensity) -> Cell
CellChar Char
c Bold
b Bold
r (forall a. a -> Maybe a
Just (Color
k, ColorIntensity
i))
colorCell Color
_ ColorIntensity
_ Cell
Transparent = Cell
Transparent
boldCell :: Cell -> Cell
boldCell :: Cell -> Cell
boldCell (CellChar Char
c Bold
_ Bold
r Maybe (Color, ColorIntensity)
k) = Char -> Bold -> Bold -> Maybe (Color, ColorIntensity) -> Cell
CellChar Char
c Bold
True Bold
r Maybe (Color, ColorIntensity)
k
boldCell Cell
Transparent = Cell
Transparent
reverseCell :: Cell -> Cell
reverseCell :: Cell -> Cell
reverseCell (CellChar Char
c Bold
b Bold
_ Maybe (Color, ColorIntensity)
k) = Char -> Bold -> Bold -> Maybe (Color, ColorIntensity) -> Cell
CellChar Char
c Bold
b Bold
True Maybe (Color, ColorIntensity)
k
reverseCell Cell
Transparent = Cell
Transparent
stringPlane :: String -> Plane
stringPlane :: String -> Plane
stringPlane String
t = Maybe Char -> String -> Plane
stringPlaneGeneric forall a. Maybe a
Nothing String
t
stringPlaneTrans :: Char -> String -> Plane
stringPlaneTrans :: Char -> String -> Plane
stringPlaneTrans Char
c String
t = Maybe Char -> String -> Plane
stringPlaneGeneric (forall a. a -> Maybe a
Just Char
c) String
t
blankPlane :: Width -> Height -> Plane
blankPlane :: Row -> Row -> Plane
blankPlane Row
w Row
h = Coords -> [Cell] -> Plane
listPlane (Row
h, Row
w) (forall a. a -> [a]
repeat forall a b. (a -> b) -> a -> b
$ Char -> Cell
creaCell Char
' ')
makeTransparent :: Char -> Plane -> Plane
makeTransparent :: Char -> Plane -> Plane
makeTransparent Char
tc Plane
p = (Cell -> Cell) -> Plane -> Plane
mapPlane Cell -> Cell
f Plane
p
where
f :: Cell -> Cell
f Cell
cl | Cell -> Char
cellChar Cell
cl forall a. Eq a => a -> a -> Bold
== Char
tc = Cell
Transparent
| Bold
otherwise = Cell
cl
makeOpaque :: Plane -> Plane
makeOpaque :: Plane -> Plane
makeOpaque Plane
p = let (Row
w, Row
h) = Plane -> Coords
planeSize Plane
p
in Plane -> Plane -> Coords -> Plane
pastePlane Plane
p (Row -> Row -> Plane
blankPlane Row
w Row
h) (Row
1, Row
1)
pastePlane :: Plane -> Plane -> Coords -> Plane
pastePlane :: Plane -> Plane -> Coords -> Plane
pastePlane Plane
p1 Plane
p2 (Row
r, Row
c)
| Row
r forall a. Ord a => a -> a -> Bold
> Row
h2 Bold -> Bold -> Bold
|| Row
c forall a. Ord a => a -> a -> Bold
> Row
w2 = Plane
p2
| Bold
otherwise =
let ks :: [(Coords, Cell)]
ks = Plane -> [(Coords, Cell)]
assocsPlane Plane
p1
fs :: [(Coords, Cell)]
fs = forall a. (a -> Bold) -> [a] -> [a]
filter (\(Coords, Cell)
x -> forall {a}. (a, Cell) -> Bold
solid (Coords, Cell)
x Bold -> Bold -> Bold
&& forall {b}. (Coords, b) -> Bold
inside (Coords, Cell)
x) [(Coords, Cell)]
ks
ts :: [(Coords, Cell)]
ts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
B.first Coords -> Coords
trasl) [(Coords, Cell)]
fs
in Plane -> [(Coords, Cell)] -> Plane
updatePlane Plane
p2 [(Coords, Cell)]
ts
where
trasl :: Coords -> Coords
trasl :: Coords -> Coords
trasl (Row
wr, Row
wc) = (Row
wr forall a. Num a => a -> a -> a
+ Row
r forall a. Num a => a -> a -> a
- Row
1, Row
wc forall a. Num a => a -> a -> a
+ Row
c forall a. Num a => a -> a -> a
- Row
1)
inside :: (Coords, b) -> Bold
inside (Coords
wcs, b
_) =
let (Row
r1', Row
c1') = Coords -> Coords
trasl Coords
wcs
in Row
r1' forall a. Ord a => a -> a -> Bold
>= Row
1 Bold -> Bold -> Bold
&& Row
r1' forall a. Ord a => a -> a -> Bold
<= Row
h2 Bold -> Bold -> Bold
&&
Row
c1' forall a. Ord a => a -> a -> Bold
>= Row
1 Bold -> Bold -> Bold
&& Row
c1' forall a. Ord a => a -> a -> Bold
<= Row
w2
solid :: (a, Cell) -> Bold
solid (a
_, Cell
Transparent) = Bold
False
solid (a, Cell)
_ = Bold
True
(Row
w2, Row
h2) = Plane -> Coords
planeSize Plane
p2
subPlane :: Plane -> Coords -> Coords -> Plane
subPlane :: Plane -> Coords -> Coords -> Plane
subPlane Plane
p (Row
r1, Row
c1) (Row
r2, Row
c2)
| Row
r1 forall a. Ord a => a -> a -> Bold
> Row
r2 Bold -> Bold -> Bold
|| Row
c1 forall a. Ord a => a -> a -> Bold
> Row
c2 = Char -> Plane -> Plane
makeTransparent Char
' ' (Row -> Row -> Plane
blankPlane Row
1 Row
1)
| Bold
otherwise =
let cs :: [(Coords, Cell)]
cs = Plane -> [(Coords, Cell)]
assocsPlane Plane
p
fs :: [(Coords, Cell)]
fs = forall a. (a -> Bold) -> [a] -> [a]
filter forall {b}. (Coords, b) -> Bold
f [(Coords, Cell)]
cs
(Row
pw, Row
ph) = Plane -> Coords
planeSize Plane
p
(Row
w, Row
h) = (forall a. Ord a => a -> a -> a
min Row
pw (Row
c2forall a. Num a => a -> a -> a
-Row
c1forall a. Num a => a -> a -> a
+Row
1), forall a. Ord a => a -> a -> a
min Row
ph (Row
r2forall a. Num a => a -> a -> a
-Row
r1forall a. Num a => a -> a -> a
+Row
1))
in Coords -> [Cell] -> Plane
listPlane (Row
h, Row
w) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Coords, Cell)]
fs)
where
f :: (Coords, b) -> Bold
f ((Row
rw, Row
cw), b
_) = Row
rw forall a. Ord a => a -> a -> Bold
>= Row
r1 Bold -> Bold -> Bold
&& Row
rw forall a. Ord a => a -> a -> Bold
<= Row
r2 Bold -> Bold -> Bold
&&
Row
cw forall a. Ord a => a -> a -> Bold
>= Row
c1 Bold -> Bold -> Bold
&& Row
cw forall a. Ord a => a -> a -> Bold
<= Row
c2
cellChar :: Cell -> Char
cellChar :: Cell -> Char
cellChar (CellChar Char
c Bold
_ Bold
_ Maybe (Color, ColorIntensity)
_) = Char
c
cellChar Cell
Transparent = Char
' '
cellColor :: Cell -> Maybe (CA.Color, CA.ColorIntensity)
cellColor :: Cell -> Maybe (Color, ColorIntensity)
cellColor (CellChar Char
_ Bold
_ Bold
_ Maybe (Color, ColorIntensity)
k) = Maybe (Color, ColorIntensity)
k
cellColor Cell
Transparent = forall a. Maybe a
Nothing
isBold :: Cell -> Bool
isBold :: Cell -> Bold
isBold (CellChar Char
_ Bold
b Bold
_ Maybe (Color, ColorIntensity)
_) = Bold
b
isBold Cell
_ = Bold
False
isReversed :: Cell -> Bool
isReversed :: Cell -> Bold
isReversed (CellChar Char
_ Bold
_ Bold
r Maybe (Color, ColorIntensity)
_) = Bold
r
isReversed Cell
_ = Bold
False
planePaper :: Plane -> String
planePaper :: Plane -> String
planePaper Plane
p = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Row -> [e] -> [[e]]
LS.chunksOf Row
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Cell -> Char
cellChar forall a b. (a -> b) -> a -> b
$ Plane -> [Cell]
elemsPlane Plane
p
where
w :: Int
w :: Row
w = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Plane -> Coords
planeSize forall a b. (a -> b) -> a -> b
$ Plane
p
stringPlaneGeneric :: Maybe Char -> String -> Plane
stringPlaneGeneric :: Maybe Char -> String -> Plane
stringPlaneGeneric Maybe Char
_ String
"" = Char -> Plane -> Plane
makeTransparent Char
' ' (Row -> Row -> Plane
blankPlane Row
1 Row
1)
stringPlaneGeneric Maybe Char
mc String
t = Plane
vitrous
where
lined :: [String]
lined = String -> [String]
lines String
t
h :: Int
h :: Row
h = forall (t :: * -> *) a. Foldable t => t a -> Row
length [String]
lined
w :: Int
w :: Row
w = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Row
length [String]
lined)
pad :: Int -> String -> String
pad :: Row -> ShowS
pad Row
mw String
tl = forall a. Row -> [a] -> [a]
take Row
mw (String
tl forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Char
' ')
padded :: [String]
padded :: [String]
padded = forall a b. (a -> b) -> [a] -> [b]
map (Row -> ShowS
pad Row
w) [String]
lined
celled :: [Cell]
celled :: [Cell]
celled = forall a b. (a -> b) -> [a] -> [b]
map Char -> Cell
creaCell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [String]
padded
plane :: Plane
plane :: Plane
plane = Coords -> [Cell] -> Plane
listPlane (Row
h, Row
w) [Cell]
celled
vitrous :: Plane
vitrous :: Plane
vitrous = case Maybe Char
mc of
Just Char
c -> Char -> Plane -> Plane
makeTransparent Char
c Plane
plane
Maybe Char
Nothing -> Plane
plane