{-# LANGUAGE DeriveGeneric #-}

-------------------------------------------------------------------------------

-- Screen datatypes and functions

-- 2017 Francesco Ariis GPLv3

-------------------------------------------------------------------------------


-- a canvas where to draw our stuff


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


----------------

-- DATA TYPES --

----------------


-- | 'Row's and 'Column's are 1-based (top-left position is @1 1@).

type Coords = (Row, Column)
type Row    = Int
type Column = Int

-- | Size of a surface in 'Row's and 'Column's.

type Dimensions = (Width, Height)

-- | Expressed in 'Column's.

type Width  = Int
-- | Expressed in 'Row's.

type Height = Int

type Bold     = Bool
type Reversed = Bool

-- can be an ASCIIChar or a special, transparent character

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)
        -- I found no meaningful speed improvements by making this

        -- only w/ 1 constructor.


-- | A two-dimensional surface (Row, Column) where to blit stuff.

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)
        -- Could this be made into an UArray? Nope, since UArray is

        -- only instanced on Words, Int, Chars, etc.


-------------------------------------------------------------------------------

-- Plane interface (abstracting Array)


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

-- | Dimensions or a plane.

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)

-- Array.//

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

-- faux map

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


----------

-- CREA --

----------


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

-- | Creates 'Plane' from 'String', good way to import ASCII

-- art/diagrams. Returns a 1×1 transparent plane on empty string.

stringPlane :: String -> Plane
stringPlane :: String -> Plane
stringPlane String
t = Maybe Char -> String -> Plane
stringPlaneGeneric forall a. Maybe a
Nothing String
t

-- | Same as 'stringPlane', but with transparent 'Char'.

-- Returns a 1×1 transparent plane on empty string.

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

-- | Creates an empty, opaque 'Plane'.

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
' ')

-- | Adds transparency to a plane, matching a given character

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

-- | Changes every transparent cell in the 'Plane' to an opaque @' '@

-- character.

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)



-----------

-- SLICE --

-----------


-- | Paste one plane over the other at a certain position (p1 gets over p2).

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 new position, cheaper than first mapping and then

          -- filtering.

          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

-- | Cut out a plane by top-left and bottom-right coordinates.

-- Returns a 1×1 transparent plane when @r1>r2@ or @c1>c2@.

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

-------------

-- INQUIRE --

-------------


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

-- | A String (@\n@ divided and ended) representing the 'Plane'. Useful

-- for debugging/testing purposes.

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

-----------------

-- ANCILLARIES --

-----------------


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