```{-# OPTIONS_GHC -F -pgmF htfpp #-}

{-|
Module      : Liquorice.Pure
Description : Pure functions for building Liquorice programs
Maintainer  : jon+hackage@dow.land
Stability   : experimental
Portability : POSIX

These Pure functions are the basic Liquorice primitives for constructing
Liquorice programs that evaluate to Doom maps. Monadic equivalents are defined
in `Liquorice.Monad`. Most people may find those more convenient.
-}
module Liquorice.Pure
( draw
, rightsector
, step
, turnright
, turnleft
, turnaround
, innerrightsector
, innerleftsector
, leftsector
, popsector
, thing
, mid
, upper
, lower
, xoff
, yoff
, floorflat
, ceil
, linetype
, sectortype
, setthing
, mapname
, box
, ibox
, pushpop
, place

, htf_thisModulesTests
) where

import Test.Framework
import Data.Function ((&))
import Data.List (nub)

import Liquorice
import Liquorice.Line

main = htfMain htf_thisModulesTests

-- | Move the pen forwards and sideways by the supplied amounts.
step :: Int -> Int -> Context -> Context
step forward sideways c = c { location = newloc }
where
newloc = step' (location c) (orientation c)
step' (x,y) North = (x+sideways, y+forward)
step' (x,y) South = (x-sideways, y-forward)
step' (x,y) East  = (x+forward, y-sideways)
step' (x,y) West  = (x-forward, y+sideways)

-- | Define a line from the current `location` to a new one reached by
-- moving forwards and sideways by the supplied amounts.
draw :: Int -> Int -> Context -> Context
draw forward sideways oldc = let
newc = step forward sideways oldc
newline = Line (location oldc) (location newc) (paletteTop oldc)
(paletteMid oldc) (paletteBot oldc) (paletteLineType oldc) (paletteLineTag oldc)
(paletteXoff oldc) (paletteYoff oldc)

-- | Rotate the pen to the right.
turnright :: Context -> Context
turnright c = c { orientation=next (orientation c) }

-- | Rotate the pen to the left.
turnleft :: Context -> Context
turnleft c = c { orientation=prev (orientation c) }

-- | Rotate the pen 180°.
turnaround :: Context -> Context
turnaround c = c { orientation=(next.next.orientation) c }

-- | Define a new Sector on the right-hand side of the pen.
rightsector :: Int -> Int -> Int -> Context -> Context
rightsector f c l ctx = let s = Sector f c (paletteFloor ctx) (paletteCeil ctx) l (paletteSectorType ctx) (paletteSectorTag ctx) (linedefs ctx)
newsectors = s : sectors ctx
in ctx { sectors = newsectors, linedefs = [] }

-- | Define a new Sector on the left-hand side of the pen.
leftsector :: Int -> Int -> Int -> Context -> Context
leftsector f c l ctx = let ls = map flipline (linedefs ctx)
s = Sector f c (paletteFloor ctx) (paletteCeil ctx) l (paletteSectorType ctx) (paletteSectorTag ctx) ls
newsectors = s : sectors ctx
in ctx { sectors = newsectors, linedefs = [] }

-- | Define a new inner-Sector on the right-hand side of the pen.
innerrightsector :: Int -> Int -> Int -> Context -> Context
innerrightsector f c l ctx = let last    = head (sectors ctx)
flipped = map flipline (linedefs ctx)
newlast = last { sectorLines = sectorLines last ++ flipped }
nctx    = ctx  { sectors = newlast : tail (sectors ctx) }
in  rightsector f c l nctx

-- | Define a new inner-Sector on the left-hand side of the pen.
innerleftsector :: Int -> Int -> Int -> Context -> Context
innerleftsector f c l ctx = let last    = head (sectors ctx)
newlast = last { sectorLines = sectorLines last ++ (linedefs ctx)}
nctx    = ctx  { sectors = newlast : tail (sectors ctx) }
in  leftsector f c l nctx

-- | Pop the last-defined `Sector` from the stack of defined `Sector`s and re-insert
-- it at the bottom. It remains defined, but the second-last-defined `Sector` is
-- promoted for subsequent operations that use the last-defined `Sector`.
popsector :: Context -> Context
popsector c = case length (sectors c) of
0 -> c -- XXX catch error
1 -> c -- XXX catch error
_ -> let pop  = head (sectors c)
news = tail (sectors c) ++ [pop]
in c { sectors = news }

-- XXX TESTS!!!

-- | Define a new `Thing` at the current pen location.
thing :: Context -> Context
thing c = let newthing = Thing (location c) angle (curThingType c) 7 -- all skills
angle = case orientation c of
North -> 90
East  -> 0
South -> 270
West  -> 180
in c { things = newthing : things c }

-- | Set the mid-texture value for future lines.
mid :: String -> Context -> Context
mid s c = c { paletteMid = s }

-- | Set the lower-texture value for future lines.
lower :: String -> Context -> Context
lower s c = c { paletteBot = s }

-- | Set the texture x-offset value for future lines.
xoff :: Int -> Context -> Context
xoff x c = c { paletteXoff = x }

-- | Set the texture y-offset value for future lines.
yoff :: Int -> Context -> Context
yoff y c = c { paletteYoff = y }

-- | Set the upper-texture value for future lines.
upper :: String -> Context -> Context
upper s c = c { paletteTop = s }

-- | Set the Sector floor texture for future Sectors.
floorflat :: String -> Context -> Context
floorflat s c = c { paletteFloor = s }
-- XXX: rename/harmonize with ceil

-- | Set the Sector ceiling texture for future Sectors.
ceil :: String -> Context -> Context
ceil s c = c { paletteCeil = s }

-- | Set the type and tag values for future defined `Line`s.
linetype :: Int -> Int -> Context -> Context
linetype ty tag c = c { paletteLineType = ty, paletteLineTag = tag }

-- | Set the type and tag values for future defined `Sector`s.
sectortype :: Int -> Int -> Context -> Context
sectortype ty tag c = c { paletteSectorType = ty, paletteSectorTag = tag }

-- | Set the type of future-defined `Thing`s.
setthing :: Int -> Context -> Context
setthing s c = c { curThingType = s }

-- | Set the name of the current map.
mapname :: String -> Context -> Context
mapname s c = c { mapName = s }

-- | Evaluate `fn` at a `location` offset of (x,y) from the current pen
-- location and then move the pen location back by the same relative amount.
place :: Int -> Int -> (Context -> Context) -> Context -> Context
place x y fn c = c & step x y
& fn
& step (-1 * x) (-1 * y)

test_place_pos = assertEqual (location a) (location b) where
a = start
b = place 64 64 thing start

-- | Evaluate `fn` and then re-define the `location` to the value it was
-- prior to evaluation.
pushpop :: (Context -> Context) -> Context -> Context
pushpop fn c = (fn c) { location = location c }

test_pushpop_pos = assertEqual (location a) (location b) where
a = start
b = pushpop (thing . step 64 64) start

test_no_things = assertEqual 0 (length (things start))
test_one_thing = assertEqual 1 (length (things (start & thing)))

-- | Evaluate `f` twice.
twice :: (Context -> Context) -> Context -> Context
twice f c = iterate f c !! 2

-- | Evaluate `f` four times.
quad :: (Context -> Context) -> Context -> Context
quad f c = iterate f c !! 4

-- | Define a straight `Line` of length n from the current pen position along the
-- current orientation.
straight n = draw n 0

box' :: Int -> Int -> Context -> Context
box' h w = twice (\c -> c
& straight h
& turnright
& straight w
& turnright)

-- | Define a rectangular `Sector` of the supplied size and properties.
box :: Int -> Int -> Int -> Int -> Int -> Context -> Context
box h w f ceil l c = c
& box' h w
& rightsector f ceil l

-- | Define a rectangular inner-`Sector` of the supplied size and properties,
-- parented to the last-drawn Sector.
ibox :: Int -> Int -> Int -> Int -> Int -> Context -> Context
ibox h w f ceil l c = c
& box' h w
& innerrightsector f ceil l

-- | Check intersections against all existing lines
addLine :: Line -> Context -> Context
news       = map (\s-> s { sectorLines = splitLines (sectorLines s) l }) (sectors c)
alllines   = linedefs c ++ concatMap sectorLines news
intersects = filter (checkIntersect l) alllines
newlines   = if length intersects > 0
then workbest [l] intersects
else [l]
in c { sectors = news, linedefs = linedefs c ++ newlines }

-- XXX rename!
--          lines     cuts      lines
workbest :: [Line] -> [Line] -> [Line]
workbest [] _ = []
workbest ls [] = ls
workbest (l:ls) (c:cs) =
let x = splitLine l  c
y = workbest  x  cs
z = workbest  ls (c:cs)
in  y ++ z
```