{-# OPTIONS_GHC -F -pgmF htfpp #-} {-# OPTIONS_HADDOCK prune #-} {-| Module : Liquorice.Line Description : Functions for manipulating Lines. Copyright : © Jonathan Dowland, 2020 License : GPL-3 Maintainer : jon+hackage@dow.land Stability : experimental Portability : POSIX The Point and Line data-types and functions for manipulating Lines. -} module Liquorice.Line( Line(..) , Point , flipline , splitLine , checkIntersect , splitLines , htf_thisModulesTests ) where import Data.List import Test.Framework import Control.Monad -- | A 2D coordinate. type Point = (Int, Int) -- | The Line data-type corresponds closely to the Doom equivalent but -- has with unboxed fields. data Line = Line { from :: Point , to :: Point , lineTop :: String , lineMid :: String , lineBot :: String , lineType:: Int , lineTag :: Int , lineXoff:: Int , lineYoff:: Int } deriving (Show, Eq) -- | Swap a `Line`'s direction. flipline :: Line -> Line flipline l = l { from = to l, to = from l } -- | Ordering function for `Line`s. lineOrient :: Line -> Ordering lineOrient l = let (a,b) = (from l, to l) in if a < b then GT else LT -- | Do the supplied `Line`s intersect? checkIntersect :: Line -> Line -> Bool checkIntersect a b = (sameXAxis a b || sameYAxis a b) && newCheckIntersect a b -- | Are the supplied `Line`s on the same point on the X axis? sameXAxis x y = all (==(fst (from x))) (map fst [to x, from y, to y]) -- | Are the supplied `Line`s on the same point on the Y axis? sameYAxis x y = all (==(snd (from x))) (map snd [to x, from y, to y]) -- | Utility function for `checkIntersect`. Check whether two `Line`s on the -- same plane intersect or not. -- takes advantage of tuple `Ord`. newCheckIntersect :: Line -> Line -> Bool newCheckIntersect l1 l2 = let nl1 = normalizeLine l1 nl2 = normalizeLine l2 (x1,y1) = (from nl1, to nl1) (x2,y2) = (from nl2, to nl2) in x2 >= x1 && x2 < y1 || -- start of line2 within line1 y2 > x1 && y2 <= y1 || -- end of line2 within line1 x2 <= x1 && y2 >= y1 -- line2 superset or equal to line1 mktestLine a b = Line a b "" "" "" 0 0 0 0 l1 = mktestLine (0,0) (10,0) l2 = mktestLine (0,1) ( 0,4) l3 = mktestLine (4,0) ( 8,0) l4 = mktestLine (0,2) ( 0,5) l5 = mktestLine (4,2) ( 7,2) test_xaxis_intersect = assertBool \$checkIntersect l1 l3 test_xaxis_none =(assertBool . not)\$checkIntersect l1 l2 test_yaxis_intersect = assertBool \$checkIntersect l2 l4 test_yaxis_none =(assertBool . not)\$checkIntersect l2 l3 test_xaxis_none2 =(assertBool . not)\$checkIntersect l1 l5 l9 = mktestLine (0,128) (128,128) l10= mktestLine (128,128) (192,128) test_from_example7 = (assertBool.not) \$ checkIntersect l9 l10 main = htfMain htf_thisModulesTests -- | Split `Line`s in a list with a splitter line (which we don't insert) splitLines :: [Line] -> Line -> [Line] splitLines [] _ = [] splitLines (l:ls) c = if not (checkIntersect c l) then l : splitLines ls c else if l == c then l:ls else splitLine l c ++ ls test_splitlines = assertEqual 3 (length (splitLines [l1] l3)) test_nosplitlines = assertEqual 1 (length (splitLines [l2] l1)) -- | Split a `Line` by another; return the bits. splitLine :: Line -> Line -> [Line] splitLine l cut = let (a,b) = (from l, to l) (c,d) = (from cut, to cut) in if normalizeLine l == normalizeLine cut then [l] else let [e,f,g,h] = sort [a,b,c,d] nl1 = l { from = e, to = f } nl2 = l { from = f, to = g } nl3 = l { from = g, to = h } in map (if lineOrient l == LT then flipline else id) \$ filter (\m -> from m /= to m && checkIntersect l m) [nl1, nl2, nl3] test_splitline_self1 = assertEqual [l1] \$ splitLine l1 (flipline l1) test_splitline_self2 = assertEqual [l1] \$ splitLine l1 l1 test_splitline_self3 = assertEqual [flipline l1] \$ splitLine (flipline l1) l1 l11 = mktestLine (0,64) (0,128) l12 = mktestLine (0,192) (0,64) l13 = mktestLine (0,0) (0,128) test_nosplit = assertEqual [l11] (splitLine l11 l12) -- temporarily straight line! -- limit the range of possible coordinate values to increase the likelyhood -- of overlap for the default number of tests. Doom's actual range is -- -32768 to +32767, but a more realistic upper limit is a range of about -- 5000 units (MAP29) instance Arbitrary Line where arbitrary = do vs <- replicateM 2 (choose (-2500, 2500)) let [x,y] = vs return (mktestLine (x,0) (y,0)) prop_splitline_sameorient :: Line -> Line -> Bool prop_splitline_sameorient x y = (>0) \$ length \$ filter (== (lineOrient x)) \$ map lineOrient (splitLine x y) test_splitline_sameorient1 = assertBool (prop_splitline_sameorient l12 l13) test_splitline_sameorient2 = assertBool (prop_splitline_sameorient l13 l12) -- catch case where the new lines from a split intersect existing lines l6 = mktestLine (0,0) (0,2) l7 = mktestLine (0,4) (0,6) l8 = mktestLine (0,1) (0,5) test_alldone = let split1 = splitLines [l6,l7] l8 repeat = split1 !! 2 split2 = splitLines split1 repeat in assertEqual split1 split2 -- (probably worth writing a property, too) -- again leveraging Ord tuple instance Ord Line where x <= y = let (a,b,c,d) = (from x, to x, from y, to y) in (a,b) < (c,d) normalizeLine l = if (from l) > (to l) then flipline l else l test_rev_xaxis_intersect = assertBool \$checkIntersect l1 (flipline l3) test_rev_xaxis_none =(assertBool . not)\$checkIntersect l1 (flipline l2) test_rev_yaxis_intersect = assertBool \$checkIntersect l2 (flipline l4) test_rev_yaxis_intersect2 = assertBool \$checkIntersect (flipline l2) (flipline l4) test_rev_yaxis_none =(assertBool . not)\$checkIntersect l2 (flipline l3) test_rev_xaxis_none2 =(assertBool . not)\$checkIntersect l1 (flipline l5) test_rev_splitlines = assertEqual 3 (length (splitLines [l1] (flipline l3))) test_rev_nosplitlines = assertEqual 1 (length (splitLines [l2] (flipline l1))) test_rev_recurse = assertEqual 1 (length (splitLines [l1] (flipline l1))) l14 = mktestLine (0,0) (128,0) l15 = mktestLine (256,0) (384,0) l16 = mktestLine (-256,0) (512,0) -- XXX need a test here (import example9)