bring back shrinking in simpler form

bring back shrinking in simpler form

module App.Geometry where

import Prelude
import Data.Function (on)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.List (List(..), concatMap, filter, find, foldl, head, length, mapMaybe, nub, reverse, singleton, snoc, sort, sortBy, zipWith, (:))
import Data.Map (Map, empty, insert, values)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), snd)
import Math (Radians, abs, atan2, cos, pi, pow, round, sin, sqrt, trunc)

data Point = Point Number Number

{--
approxEq :: Number -> Number -> Boolean
approxEq a b =
  abs (a - b) < 1.0
--}

instance ptOrd :: Ord Point where
  compare (Point x1 y1) (Point x2 y2) = compare x1 x2 <> compare y1 y2

instance ptEq :: Eq Point where
  eq (Point x1 y1) (Point x2 y2) = x1 == x2 && y1 == y2

instance ptShow :: Show Point where
  show (Point x y) = "(" <> show x <> ", " <> show y <> ")"

instance ptRing :: Ring Point where
  sub (Point x1 y1) (Point x2 y2) = Point (x1 - x2) (y1 - y2)

instance ptSemiring :: Semiring Point where
  add (Point x1 y1) (Point x2 y2) = Point (x1 + x2) (y1 + y2)
  mul (Point x1 y1) (Point x2 y2) = Point (x1 * x2) (y1 * y2)
  zero = Point 0.0 0.0
  one = Point 1.0 1.0

ptX :: Point -> Number
ptX (Point x _) = x

ptY :: Point -> Number
ptY (Point _ y) = y

scalePt :: Point -> Number -> Point
scalePt (Point x y) c = Point (c * x) (c * y)

normalize :: Point -> Point
normalize p@(Point x y) =
  let m = runFn2 distance (Point 0.0 0.0) p
   in Point (x/m) (y/m)

rotate :: Point -> Radians -> Point
rotate (Point x y) theta =
  Point (x * (cos theta) - y * (sin theta)) (x * (sin theta) + y * (cos theta))

foreign import ptAngle :: Fn2 Point Point Radians
foreign import distance :: Fn2 Point Point Number

getAngleDiff :: Radians -> Radians -> Boolean -> Radians
getAngleDiff a1 a2 ccw =
  case a2 - a1 of diff | diff < 0.0 && ccw -> diff + 2.0 * pi
                       | diff > 0.0 && (not ccw) -> diff - 2.0 * pi
                       | otherwise -> diff

ptSweep :: Point -> Point -> Point -> Boolean -> Radians
ptSweep c p q ccw =
  getAngleDiff (runFn2 ptAngle c p) (runFn2 ptAngle c q) ccw

mapPt :: (Number -> Number) -> Point -> Point
mapPt f (Point x y) = Point (f x) (f y)

crossProduct :: Point -> Point -> Number
crossProduct (Point x1 y1) (Point x2 y2) = x1 * y2 - x2 * y1

dotProduct :: Point -> Point -> Number
dotProduct (Point x1 y1) (Point x2 y2) = x1*x2 + y1*y2

getNearestPoint :: Point -> List Point -> Maybe Point
getNearestPoint _ Nil = Nothing
getNearestPoint p ps = foldl updateMax Nothing ps
  where
    updateMax :: Maybe Point -> Point -> Maybe Point
    updateMax Nothing p1 = Just p1
    updateMax (Just p1) p2 = if (runFn2 distance p p1) < (runFn2 distance p p2) then Just p1 else Just p2

data Stroke = Line Point Point
            | Arc Point Point Point Boolean

instance strokeEq :: Eq Stroke where
  eq (Line p1 p2) (Line q1 q2) = p1 == q1 && p2 == q2
  eq (Arc c p q ccw) (Arc c' p' q' ccw') = c == c' && p == p' && q == q' && ccw == ccw'
  eq _ _ = false

unorderedEq :: Stroke -> Stroke -> Boolean
unorderedEq s1 s2 = s1 == s2 || (flipStroke s1) == s2

instance strokeShow :: Show Stroke where
  show (Line p1 p2) =
    "[" <> show p1 <> " --- " <> show p2 <> "]"

  show (Arc c p q ccw) =
    "( center: " <> show c <> ", p: " <> show p <> ", q: " <> show q <> ", ccw: " <> show ccw <> ")"

compareMap :: forall a. (Ord a) => List (Stroke -> a) -> Stroke -> Stroke -> Ordering
compareMap (fn : rest) s1 s2 = case compare (fn s1) (fn s2) of
                                    EQ -> compareMap rest s1 s2
                                    ord -> ord
compareMap Nil _ _ = EQ

instance strokeOrd :: Ord Stroke where
  compare =  (compare `on` firstPoint)
          <> (compare `on` (outboundAngle >>> truncTo5))
          <> (compare `on` curvature)
          <> (compare `on` strokeLength)

firstPoint :: Stroke -> Point
firstPoint (Line p1 _) = p1
firstPoint (Arc _ p _ _) = p

secondPoint :: Stroke -> Point
secondPoint (Line _ p2) = p2
secondPoint (Arc _ _ q _) = q

sweep :: Stroke -> Radians
sweep (Line _ _) = 0.0
sweep (Arc c p q ccw) =
  case ptSweep c p q ccw of s | s == 0.0 -> if ccw then 2.0 * pi else -2.0 * pi
                              | otherwise -> s

truncTo5 :: Number -> Number
truncTo5 num = (trunc (num * 100000.0)) / 100000.0

outboundAngle :: Stroke -> Radians
outboundAngle (Line (Point x1 y1) (Point x2 y2)) =
  atan2 (y2 - y1) (x2 - x1)

outboundAngle (Arc c p _ ccw) =
  let a = runFn2 ptAngle c p
   in atan2Radians $ a + if ccw then (pi / 2.0) else (- pi / 2.0)

inboundAngle :: Stroke -> Radians
inboundAngle s@(Line _ _) = outboundAngle s
inboundAngle (Arc c _ q ccw) =
  let a = runFn2 ptAngle c q
   in a + if ccw then (pi / 2.0) else (- pi / 2.0)

-- communicates how aggressively the curve turns. Lines don't turn at all, so have curvature 0
-- arcs, when sorted by curvature will go from small-radii counterclockwise arcs, to large-radii ones (with a limit
-- of a line at 0), then large-radii clockwise arcs (which are negative) and finally small-radii counterclockwise
-- arcs (which are the most negative).
curvature :: Stroke -> Number
curvature (Line _ _) = 0.0
curvature (Arc c p _ ccw) =
  let r = (runFn2 distance c p)
   in if ccw then 1.0 / r else - 1.0 / r

foreign import strokeLength :: Stroke -> Number
-- strokeLength :: Stroke -> Number
-- strokeLength (Line (Point x1 y1) (Point x2 y2)) = (pow (x2 - x1) 2.0) + (pow (y2 - y1) 2.0)
-- strokeLength a@(Arc c p _ _) = (sweep a) * (runFn2 distance c p)

-- clockwise rotation -> positive angle
-- ->/ == negative
-- ->\ == positive
angleDiff :: Stroke -> Stroke -> Radians
angleDiff strokeIn strokeOut =
  let a1 = outboundAngle strokeOut
      a2 = inboundAngle strokeIn
      diff = atan2Radians (a1 - a2)
   in if (abs $ truncTo5 diff) == truncTo5 pi then case compare strokeOut (flipStroke strokeIn) of EQ -> -pi
                                                                                LT -> pi
                                                                                GT -> -pi
                                       else diff

findWrap :: Path -> Radians
findWrap Nil = 0.0
findWrap path@(s1 : rest) =
  foldl (+) 0.0 (angles <> (sweep <$> path))
  where
    -- include the angle from the last to the first stroke as well
    angles = zipWith angleDiff path (snoc rest s1)

flipStroke :: Stroke -> Stroke
flipStroke (Line p1 p2) = Line p2 p1
flipStroke (Arc c p q ccw) = Arc c q p (not ccw)

roundStroke :: Stroke -> Stroke
roundStroke (Line p1 p2) = Line (roundPt p1) (roundPt p2)
roundStroke (Arc c p q ccw) = Arc (roundPt c) (roundPt p) (roundPt q) ccw

positiveRadians :: Radians -> Radians
positiveRadians a
  | a < 0.0 = a + 2.0 * pi
  | a > 2.0 * pi = a - 2.0 * pi
  | otherwise = a

atan2Radians :: Radians -> Radians
atan2Radians a
  | a > pi = a - 2.0 * pi
  | a < -pi = a + 2.0 * pi
  | otherwise = a

type Path = List Stroke
type Intersections = Map Stroke (List Stroke)

reversePath :: Path -> Path
reversePath path =
  flipStroke <$> reverse path

swapEdge :: Path -> Stroke -> Path -> Path
swapEdge (c : cs) s ss
  | c == s = ss <> cs
  | c == (flipStroke s) = (reversePath ss) <> cs
  | otherwise = c : (swapEdge cs s ss)
swapEdge Nil _ _ = Nil

-- is the potential solution within the bounds of this stroke?
withinBounds :: Stroke -> Point -> Boolean
withinBounds (Line (Point x1 y1) (Point x2 y2)) (Point x y) =
  let between a a1 a2 = (a1 <= a && a <= a2) || (a1 >= a && a >= a2)
   in (between x x1 x2) && (between y y1 y2)

withinBounds arc@(Arc c p _ ccw) sol =
  let adiff = getAngleDiff (runFn2 ptAngle c p) (runFn2 ptAngle c sol) ccw
   in (abs adiff) <= (abs (sweep arc))

intersect :: Stroke -> Stroke -> (List Point)
intersect (Line p p') (Line q q') =
  let
    r = p' - p
    s = q' - q
    rxs = r `crossProduct` s
    qp = q - p
    qpxs = qp `crossProduct` s
    qpxr = qp `crossProduct` r
  in
    if rxs == 0.0 then
      if qpxr == 0.0 then -- segments are colinear
        let
          rr = (r `dotProduct` r)
          t0 = (qp `dotProduct` r) / rr
          t1 = ((qp + s) `dotProduct` r) / rr
          s1 = min t0 t1
          s2 = max t0 t1
        in Nil -- TODO: segments are colinear and overlapping
      else Nil -- segments are parallel and not colinear
    else
      let
        t = qpxs / rxs
        u = qpxr / rxs
      in
        if 0.0 <= t && t <= 1.0 && 0.0 <= u && u <= 1.0 then singleton (p + ((*) t) `mapPt` r)
                                                        else Nil

intersect line@(Line (Point lx1 ly1) (Point lx2 ly2)) arc@(Arc c@(Point cx cy) p q ccw) =
  let check sol = (withinBounds line sol) && (withinBounds arc sol)
   in if lx2 == lx1 then
     let r = runFn2 distance c p
         disc = r * r - (pow (cx - lx1) 2.0)

         getSolution d =
           let y = cy + d
               solution = Point lx1 y
            in if check solution then Just solution
                                 else Nothing

      in case disc of
              _ | disc < 0.0 -> Nil
                | disc == 0.0 -> mapMaybe getSolution (0.0 : Nil)
                | otherwise -> mapMaybe getSolution (sqrt disc : -(sqrt disc) : Nil)

    else
      let m = (ly2 - ly1) / (lx2 - lx1)
          b = ly1 - (m * lx1)
          cA = m * m + 1.0
          cB = 2.0 * (m * b - m * cy - cx)
          r = runFn2 distance c p
          cC = cy * cy - r * r + cx * cx - 2.0 * b * cy + b * b
          disc = cB*cB - 4.0 * cA * cC

          -- plug in a value for the determinant
          getSolution d =
            let x = (-cB + d) / (2.0 * cA)
                y = m * x + b
                solution = Point x y
             in if check solution then Just solution
                                  else Nothing

       in case disc of
               _ | disc < 0.0 -> Nil
                 | disc == 0.0 -> mapMaybe getSolution (0.0 : Nil)
                 | otherwise -> mapMaybe getSolution (sqrt disc : -(sqrt disc) : Nil)

intersect arc1@(Arc c1 p1 q1 ccw1) arc2@(Arc c2 p2 q2 ccw2) =
  let r1 = runFn2 distance c1 p1
      r2 = runFn2 distance c2 p2
      d = runFn2 distance c1 c2
      a = (r1 * r1 - r2 * r2 + d * d) / (2.0 * d)
      cvec = normalize (c2 - c1)
      check sol = (withinBounds arc1 sol) && (withinBounds arc2 sol)
   in filter check (
     case true of _ | d > r1 + r2 -> Nil -- circles too far apart
                    | d < abs (r1 - r2) -> Nil -- one circle inside the other
                    | d == r1 + r2 -> ((c1 + (scalePt cvec r1)) : Nil) -- circles are touching
                    | otherwise ->
                        let h = sqrt (r1 * r1 - a * a)
                            hvec = scalePt (rotate cvec (pi/2.0)) h
                            pt = c1 + (scalePt cvec a) -- where the center line and intersection line meet
                         in ((pt + hvec) : (pt - hvec) : Nil)
   )

intersect a@(Arc _ _ _ _) l@(Line _ _) = intersect l a

insertPath ::  Intersections -> Stroke -> Path -> Intersections
insertPath intersections stroke splitStroke =
  insert stroke splitStroke $ insert (flipStroke stroke) (reversePath splitStroke) intersections

roundPt :: Point -> Point
roundPt (Point x y) =
  let acc = 1000.0
   in Point ((round $ x * acc) / acc) ((round $ y * acc) / acc)

intersectMultiple :: Stroke -> List Stroke -> Intersections
intersectMultiple stroke strokes =
  let
    intersectionTuples = do
      toIntersect <- strokes
      case intersect stroke toIntersect of
           Nil -> Nil
           newPoints -> pure $ Tuple toIntersect newPoints

    getPoints (Line p1 p2) = p1 : p2 : Nil
    getPoints (Arc c p q _) = c : p : q : Nil

    -- we don't want slight inequalities in floating point arithmetic to cause multiple nearby points to be created
    -- since we rely on point equality to do cycle detection.
    -- if an intersection point is near an existing point, or another intersection point, replace it
    allPoints = (concatMap getPoints strokes) <> concatMap snd intersectionTuples

    shrunkTuples =
      let shrinkPoint pt = case find (\existingPoint -> (runFn2 distance pt existingPoint) < 0.05) allPoints of
                                Just newPt -> newPt
                                Nothing -> pt
       in (\(Tuple edge intersections) -> (Tuple edge (shrinkPoint <$> intersections))) <$> intersectionTuples

    insertPoints i (Tuple edge points) =
      insertPath i edge (split edge points)

    intersections = foldl insertPoints empty intersectionTuples
  in
    insertPath intersections stroke (split stroke (concatMap snd intersectionTuples))

nubAdjacent :: forall a. (Eq a) => List a -> List a
nubAdjacent (a : b : rest) | a == b = (nubAdjacent $ a : rest)
                           | otherwise = a : (nubAdjacent $ b : rest)

nubAdjacent (a : Nil) = a : Nil
nubAdjacent Nil = Nil

-- given a stroke and a list of intersections, return a list of strokes
split :: Stroke -> List Point -> List Stroke
split (Line p1 p2) points =
  case head lines of -- ensure we still go from p1 to p2
       Just (Line p _) | p == p1 -> lines
       _ -> reversePath lines
  where
    sortedPoints = sort $ nub $ p1 : p2 : points
    zipPointPairs (p : q : rest) = (Line p q) : (zipPointPairs (q : rest))
    zipPointPairs _ = Nil
    lines = zipPointPairs sortedPoints

split arc@(Arc c p q ccw) points =
  let
      intersectionSweep i = ptSweep c p i ccw

      -- remove p and q from intersections since we will add them back later
      intersections = sortBy (compare `on` intersectionSweep) $
                      (filter (\pt -> pt /= p && pt /= q) points)

      -- sandwich the intersections, in the right order, between p and q
      orderedIntersections = nubAdjacent $
         p : (snoc (if ccw then intersections else reverse intersections) q)

      zipAnglePairs (p1 : p2 : rest) =
        (Arc c p1 p2 ccw) : zipAnglePairs (p2 : rest)
      zipAnglePairs _ = Nil

   in if (length orderedIntersections > 2) then (zipAnglePairs orderedIntersections)
                                           else (singleton arc)

module App.Geometry where

import Prelude
import Data.Function (on)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.List (List(..), concatMap, filter, foldl, head, length, mapMaybe, nub, reverse, singleton, snoc, sort, sortBy, zipWith, (:))
import Data.Map (Map, empty, insert, values)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), snd)
import Math (Radians, abs, atan2, cos, pi, pow, round, sin, sqrt, trunc)

data Point = Point Number Number

{--
approxEq :: Number -> Number -> Boolean
approxEq a b =
  abs (a - b) < 1.0
--}

instance ptOrd :: Ord Point where
  compare (Point x1 y1) (Point x2 y2) = compare x1 x2 <> compare y1 y2

instance ptEq :: Eq Point where
  eq (Point x1 y1) (Point x2 y2) = x1 == x2 && y1 == y2

instance ptShow :: Show Point where
  show (Point x y) = "(" <> show x <> ", " <> show y <> ")"

instance ptRing :: Ring Point where
  sub (Point x1 y1) (Point x2 y2) = Point (x1 - x2) (y1 - y2)

instance ptSemiring :: Semiring Point where
  add (Point x1 y1) (Point x2 y2) = Point (x1 + x2) (y1 + y2)
  mul (Point x1 y1) (Point x2 y2) = Point (x1 * x2) (y1 * y2)
  zero = Point 0.0 0.0
  one = Point 1.0 1.0

ptX :: Point -> Number
ptX (Point x _) = x

ptY :: Point -> Number
ptY (Point _ y) = y

scalePt :: Point -> Number -> Point
scalePt (Point x y) c = Point (c * x) (c * y)

normalize :: Point -> Point
normalize p@(Point x y) =
  let m = runFn2 distance (Point 0.0 0.0) p
   in Point (x/m) (y/m)

rotate :: Point -> Radians -> Point
rotate (Point x y) theta =
  Point (x * (cos theta) - y * (sin theta)) (x * (sin theta) + y * (cos theta))

foreign import ptAngle :: Fn2 Point Point Radians
foreign import distance :: Fn2 Point Point Number

getAngleDiff :: Radians -> Radians -> Boolean -> Radians
getAngleDiff a1 a2 ccw =
  case a2 - a1 of diff | diff < 0.0 && ccw -> diff + 2.0 * pi
                       | diff > 0.0 && (not ccw) -> diff - 2.0 * pi
                       | otherwise -> diff

ptSweep :: Point -> Point -> Point -> Boolean -> Radians
ptSweep c p q ccw =
  getAngleDiff (runFn2 ptAngle c p) (runFn2 ptAngle c q) ccw

mapPt :: (Number -> Number) -> Point -> Point
mapPt f (Point x y) = Point (f x) (f y)

crossProduct :: Point -> Point -> Number
crossProduct (Point x1 y1) (Point x2 y2) = x1 * y2 - x2 * y1

dotProduct :: Point -> Point -> Number
dotProduct (Point x1 y1) (Point x2 y2) = x1*x2 + y1*y2

getNearestPoint :: Point -> List Point -> Maybe Point
getNearestPoint _ Nil = Nothing
getNearestPoint p ps = foldl updateMax Nothing ps
  where
    updateMax :: Maybe Point -> Point -> Maybe Point
    updateMax Nothing p1 = Just p1
    updateMax (Just p1) p2 = if (runFn2 distance p p1) < (runFn2 distance p p2) then Just p1 else Just p2

data Stroke = Line Point Point
            | Arc Point Point Point Boolean

instance strokeEq :: Eq Stroke where
  eq (Line p1 p2) (Line q1 q2) = p1 == q1 && p2 == q2
  eq (Arc c p q ccw) (Arc c' p' q' ccw') = c == c' && p == p' && q == q' && ccw == ccw'
  eq _ _ = false

unorderedEq :: Stroke -> Stroke -> Boolean
unorderedEq s1 s2 = s1 == s2 || (flipStroke s1) == s2

instance strokeShow :: Show Stroke where
  show (Line p1 p2) =
    "[" <> show p1 <> " --- " <> show p2 <> "]"

  show (Arc c p q ccw) =
    "( center: " <> show c <> ", p: " <> show p <> ", q: " <> show q <> ", ccw: " <> show ccw <> ")"

compareMap :: forall a. (Ord a) => List (Stroke -> a) -> Stroke -> Stroke -> Ordering
compareMap (fn : rest) s1 s2 = case compare (fn s1) (fn s2) of
                                    EQ -> compareMap rest s1 s2
                                    ord -> ord
compareMap Nil _ _ = EQ

instance strokeOrd :: Ord Stroke where
  compare =  (compare `on` firstPoint)
          <> (compare `on` (outboundAngle >>> truncTo5))
          <> (compare `on` curvature)
          <> (compare `on` strokeLength)

firstPoint :: Stroke -> Point
firstPoint (Line p1 _) = p1
firstPoint (Arc _ p _ _) = p

secondPoint :: Stroke -> Point
secondPoint (Line _ p2) = p2
secondPoint (Arc _ _ q _) = q

sweep :: Stroke -> Radians
sweep (Line _ _) = 0.0
sweep (Arc c p q ccw) =
  case ptSweep c p q ccw of s | s == 0.0 -> if ccw then 2.0 * pi else -2.0 * pi
                              | otherwise -> s

truncTo5 :: Number -> Number
truncTo5 num = (trunc (num * 100000.0)) / 100000.0

outboundAngle :: Stroke -> Radians
outboundAngle (Line (Point x1 y1) (Point x2 y2)) =
  atan2 (y2 - y1) (x2 - x1)

outboundAngle (Arc c p _ ccw) =
  let a = runFn2 ptAngle c p
   in atan2Radians $ a + if ccw then (pi / 2.0) else (- pi / 2.0)

inboundAngle :: Stroke -> Radians
inboundAngle s@(Line _ _) = outboundAngle s
inboundAngle (Arc c _ q ccw) =
  let a = runFn2 ptAngle c q
   in a + if ccw then (pi / 2.0) else (- pi / 2.0)

-- communicates how aggressively the curve turns. Lines don't turn at all, so have curvature 0
-- arcs, when sorted by curvature will go from small-radii counterclockwise arcs, to large-radii ones (with a limit
-- of a line at 0), then large-radii clockwise arcs (which are negative) and finally small-radii counterclockwise
-- arcs (which are the most negative).
curvature :: Stroke -> Number
curvature (Line _ _) = 0.0
curvature (Arc c p _ ccw) =
  let r = (runFn2 distance c p)
   in if ccw then 1.0 / r else - 1.0 / r

foreign import strokeLength :: Stroke -> Number
-- strokeLength :: Stroke -> Number
-- strokeLength (Line (Point x1 y1) (Point x2 y2)) = (pow (x2 - x1) 2.0) + (pow (y2 - y1) 2.0)
-- strokeLength a@(Arc c p _ _) = (sweep a) * (runFn2 distance c p)

-- clockwise rotation -> positive angle
-- ->/ == negative
-- ->\ == positive
angleDiff :: Stroke -> Stroke -> Radians
angleDiff strokeIn strokeOut =
  let a1 = outboundAngle strokeOut
      a2 = inboundAngle strokeIn
      diff = atan2Radians (a1 - a2)
   in if (abs $ truncTo5 diff) == truncTo5 pi then case compare strokeOut (flipStroke strokeIn) of EQ -> -pi
                                                                                LT -> pi
                                                                                GT -> -pi
                                       else diff

findWrap :: Path -> Radians
findWrap Nil = 0.0
findWrap path@(s1 : rest) =
  foldl (+) 0.0 (angles <> (sweep <$> path))
  where
    -- include the angle from the last to the first stroke as well
    angles = zipWith angleDiff path (snoc rest s1)

flipStroke :: Stroke -> Stroke
flipStroke (Line p1 p2) = Line p2 p1
flipStroke (Arc c p q ccw) = Arc c q p (not ccw)

roundStroke :: Stroke -> Stroke
roundStroke (Line p1 p2) = Line (roundPt p1) (roundPt p2)
roundStroke (Arc c p q ccw) = Arc (roundPt c) (roundPt p) (roundPt q) ccw

positiveRadians :: Radians -> Radians
positiveRadians a
  | a < 0.0 = a + 2.0 * pi
  | a > 2.0 * pi = a - 2.0 * pi
  | otherwise = a

atan2Radians :: Radians -> Radians
atan2Radians a
  | a > pi = a - 2.0 * pi
  | a < -pi = a + 2.0 * pi
  | otherwise = a

type Path = List Stroke
type Intersections = Map Stroke (List Stroke)

reversePath :: Path -> Path
reversePath path =
  flipStroke <$> reverse path

swapEdge :: Path -> Stroke -> Path -> Path
swapEdge (c : cs) s ss
  | c == s = ss <> cs
  | c == (flipStroke s) = (reversePath ss) <> cs
  | otherwise = c : (swapEdge cs s ss)
swapEdge Nil _ _ = Nil

-- is the potential solution within the bounds of this stroke?
withinBounds :: Stroke -> Point -> Boolean
withinBounds (Line (Point x1 y1) (Point x2 y2)) (Point x y) =
  let between a a1 a2 = (a1 <= a && a <= a2) || (a1 >= a && a >= a2)
   in (between x x1 x2) && (between y y1 y2)

withinBounds arc@(Arc c p _ ccw) sol =
  let adiff = getAngleDiff (runFn2 ptAngle c p) (runFn2 ptAngle c sol) ccw
   in (abs adiff) <= (abs (sweep arc))

intersect :: Stroke -> Stroke -> (List Point)
intersect (Line p p') (Line q q') =
  let
    r = p' - p
    s = q' - q
    rxs = r `crossProduct` s
    qp = q - p
    qpxs = qp `crossProduct` s
    qpxr = qp `crossProduct` r
  in
    if rxs == 0.0 then
      if qpxr == 0.0 then -- segments are colinear
        let
          rr = (r `dotProduct` r)
          t0 = (qp `dotProduct` r) / rr
          t1 = ((qp + s) `dotProduct` r) / rr
          s1 = min t0 t1
          s2 = max t0 t1
        in Nil -- TODO: segments are colinear and overlapping
      else Nil -- segments are parallel and not colinear
    else
      let
        t = qpxs / rxs
        u = qpxr / rxs
      in
        if 0.0 <= t && t <= 1.0 && 0.0 <= u && u <= 1.0 then singleton (p + ((*) t) `mapPt` r)
                                                        else Nil

intersect line@(Line (Point lx1 ly1) (Point lx2 ly2)) arc@(Arc c@(Point cx cy) p q ccw) =
  let check sol = (withinBounds line sol) && (withinBounds arc sol)
   in if lx2 == lx1 then
     let r = runFn2 distance c p
         disc = r * r - (pow (cx - lx1) 2.0)

         getSolution d =
           let y = cy + d
               solution = Point lx1 y
            in if check solution then Just solution
                                 else Nothing

      in case disc of
              _ | disc < 0.0 -> Nil
                | disc == 0.0 -> mapMaybe getSolution (0.0 : Nil)
                | otherwise -> mapMaybe getSolution (sqrt disc : -(sqrt disc) : Nil)

    else
      let m = (ly2 - ly1) / (lx2 - lx1)
          b = ly1 - (m * lx1)
          cA = m * m + 1.0
          cB = 2.0 * (m * b - m * cy - cx)
          r = runFn2 distance c p
          cC = cy * cy - r * r + cx * cx - 2.0 * b * cy + b * b
          disc = cB*cB - 4.0 * cA * cC

          -- plug in a value for the determinant
          getSolution d =
            let x = (-cB + d) / (2.0 * cA)
                y = m * x + b
                solution = Point x y
             in if check solution then Just solution
                                  else Nothing

       in case disc of
               _ | disc < 0.0 -> Nil
                 | disc == 0.0 -> mapMaybe getSolution (0.0 : Nil)
                 | otherwise -> mapMaybe getSolution (sqrt disc : -(sqrt disc) : Nil)

intersect arc1@(Arc c1 p1 q1 ccw1) arc2@(Arc c2 p2 q2 ccw2) =
  let r1 = runFn2 distance c1 p1
      r2 = runFn2 distance c2 p2
      d = runFn2 distance c1 c2
      a = (r1 * r1 - r2 * r2 + d * d) / (2.0 * d)
      cvec = normalize (c2 - c1)
      check sol = (withinBounds arc1 sol) && (withinBounds arc2 sol)
   in filter check (
     case true of _ | d > r1 + r2 -> Nil -- circles too far apart
                    | d < abs (r1 - r2) -> Nil -- one circle inside the other
                    | d == r1 + r2 -> ((c1 + (scalePt cvec r1)) : Nil) -- circles are touching
                    | otherwise ->
                        let h = sqrt (r1 * r1 - a * a)
                            hvec = scalePt (rotate cvec (pi/2.0)) h
                            pt = c1 + (scalePt cvec a) -- where the center line and intersection line meet
                         in ((pt + hvec) : (pt - hvec) : Nil)
   )

intersect a@(Arc _ _ _ _) l@(Line _ _) = intersect l a

insertPath ::  Intersections -> Stroke -> Path -> Intersections
insertPath intersections stroke splitStroke =
  insert stroke splitStroke $ insert (flipStroke stroke) (reversePath splitStroke) intersections

-- look over the points in order. If a point is close to an earlier point, map from that point to the earlier point
makePtMap :: List Point -> Map Point Point
makePtMap points =
  let mapPoint map p =
        let nearbyPt = head $ filter (\existingPt -> (runFn2 distance p existingPt) < 0.05) (values map)
         in case nearbyPt of
                 Just pt -> insert p pt map
                 Nothing -> insert p p map

   in foldl mapPoint empty points

roundPt :: Point -> Point
roundPt (Point x y) =
  let acc = 1000.0
   in Point ((round $ x * acc) / acc) ((round $ y * acc) / acc)

intersectMultiple :: Stroke -> List Stroke -> Intersections
intersectMultiple stroke strokes =
  let
    intersectionTuples = do
      toIntersect <- strokes
      case intersect stroke toIntersect of
           Nil -> Nil
           newPoints -> pure $ Tuple toIntersect newPoints

    --getPoints (Line p1 p2) = p1 : p2 : Nil
    --getPoints (Arc c p q _) = c : p : q : Nil

    -- we don't want slight inequalities in floating point arithmetic to cause multiple nearby points to be created
    -- since we rely on point equality to do cycle detection.
    -- if an intersection point is near an existing point, or another intersection point, replace it
    --ptMap = makePtMap $ (concatMap getPoints strokes) <> (concatMap snd intersectionTuples)
    --shrunkTuples =
    --  let shrinkPoint pt = case lookup pt ptMap of
    --                            Just newPt -> newPt
    --                            Nothing -> pt
    --   in (\(Tuple edge intersections) -> (Tuple edge (shrinkPoint <$> intersections))) <$> intersectionTuples

    insertPoints i (Tuple edge points) =
      insertPath i edge (split edge points)

    intersections = foldl insertPoints empty intersectionTuples
  in
    insertPath intersections stroke (split stroke (concatMap snd intersectionTuples))

nubAdjacent :: forall a. (Eq a) => List a -> List a
nubAdjacent (a : b : rest) | a == b = (nubAdjacent $ a : rest)
                           | otherwise = a : (nubAdjacent $ b : rest)

nubAdjacent (a : Nil) = a : Nil
nubAdjacent Nil = Nil

-- given a stroke and a list of intersections, return a list of strokes
split :: Stroke -> List Point -> List Stroke
split (Line p1 p2) points =
  case head lines of -- ensure we still go from p1 to p2
       Just (Line p _) | p == p1 -> lines
       _ -> reversePath lines
  where
    sortedPoints = sort $ nub $ p1 : p2 : points
    zipPointPairs (p : q : rest) = (Line p q) : (zipPointPairs (q : rest))
    zipPointPairs _ = Nil
    lines = zipPointPairs sortedPoints

split arc@(Arc c p q ccw) points =
  let
      intersectionSweep i = ptSweep c p i ccw

      -- remove p and q from intersections since we will add them back later
      intersections = sortBy (compare `on` intersectionSweep) $
                      (filter (\pt -> pt /= p && pt /= q) points)

      -- sandwich the intersections, in the right order, between p and q
      orderedIntersections = nubAdjacent $
         p : (snoc (if ccw then intersections else reverse intersections) q)

      zipAnglePairs (p1 : p2 : rest) =
        (Arc c p1 p2 ccw) : zipAnglePairs (p2 : rest)
      zipAnglePairs _ = Nil

   in if (length orderedIntersections > 2) then (zipAnglePairs orderedIntersections)
                                           else (singleton arc)


more tracing

more tracing

module Server where

import Debug.Trace
import Data.Tuple
import Data.JSON
import Data.Function
import Data.Maybe
import Data.Array
import qualified Data.Either as E
import qualified Data.Map as M
import Data.Foldable (for_, all)
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Reactive.Timer
import Control.Lens (lens, (^.), (%~), (.~), at, LensP())

import qualified NodeWebSocket as WS
import qualified NodeHttp as Http
import Types
import Game
import Utils

initialState :: ServerState
initialState =
  { gameState: WaitingForPlayers M.empty
  , connections: []
  , callbacks: waitingCallbacks
  }

stepsPerSecond = 30

main = do
  refState <- newRef initialState

  chdir "static"
  port <- portOrDefault 8080

  httpServer <- createHttpServer
  wsServer <- createWebSocketServer refState

  WS.mount wsServer httpServer
  Http.listen httpServer port
  trace $ "listening on " <> show port <> "..."

  startMainLoop refState

createHttpServer =
  Http.createServer $ \req res -> do
    let path = (Http.getUrl req).pathname
    let reply =
      case path of
          "/"           -> Http.sendFile "index.html"
          "/js/game.js" -> Http.sendFile "js/game.js"
          _             -> Http.send404
    reply res

createWebSocketServer refState = do
  server <- WS.mkServer
  WS.onRequest server $ \req -> do
    trace "got a request"
    conn <- WS.accept req

    maybePId <- tryAddPlayer conn refState "harry" -- TODO: actual name

    case maybePId of
      Just pId -> do
        trace $ "opened connection for player " <> show pId
        runCallback refState (\c -> c.onNewPlayer) {pId:pId}

        WS.onMessage conn $ \msg ->
          runCallback refState (\c -> c.onMessage) {msg:msg, pId:pId}
        WS.onClose   conn $ \close ->
          runCallback refState (\c -> c.onClose) {pId:pId}
      Nothing -> do
        trace "rejecting connection, no player ids available"
        WS.close conn

  return server

runCallback refState callback args = do
  state <- readRef refState
  let sc = unwrapServerCallbacks state.callbacks
  state' <- callback sc args state
  writeRef refState state'

startMainLoop refState =
  void $ interval (1000 / stepsPerSecond) $
    runCallback refState (\c -> c.step) {}

tryAddPlayer conn refState name = do
  state <- readRef refState
  case getNextPlayerId state of
    Just pId -> do
      let state' = state { connections =
                            state.connections <>
                              [{ pId: pId, wsConn: conn, name: name }] }
      writeRef refState state'
      return (Just pId)
    Nothing ->
      return Nothing

getNextPlayerId :: ServerState -> Maybe PlayerId
getNextPlayerId state =
  let playerIdsInUse = map (\c -> c.pId) state.connections
  in  head $ allPlayerIds \\ playerIdsInUse

gameInProgress :: LensP ServerState GameStateInProgress
gameInProgress = lens
  (\s -> case s.gameState of
    InProgress x -> x
    _ -> error "gameInProgress: expected game to be in progress")
  (\s x -> s { gameState = InProgress x })

gameWaiting :: LensP ServerState GameStateWaitingForPlayers
gameWaiting = lens
  (\s -> case s.gameState of
    WaitingForPlayers x -> x
    _ -> error "gameWaiting: expected game to be waiting for players")
  (\s x -> s { gameState = WaitingForPlayers x })

inProgressCallbacks =
  ServerCallbacks
  { step: \args state -> do
      let g = state ^. gameInProgress
      let r = stepGame g.input g.game
      let game' = fst r
      let updates = snd r
      sendUpdates state updates
      return $ state
        { gameState = InProgress { game: game', input: M.empty }}

  , onMessage: \args state -> do
      case (eitherDecode args.msg :: E.Either String Direction) of
        E.Right newDir -> do
          {-- return $ state # gameInProgress %~ \g -> --}
          {--   let newInput = M.insert args.pId (Just newDir) g.input --}
          {--   in  {game: g.game, input: newInput} --}
          let g = state ^. gameInProgress
          let newInput = M.insert args.pId (Just newDir) g.input
          return $ state
              { gameState = InProgress { game: g.game, input: newInput }}
        E.Left err -> do
          trace $ "failed to parse message: " <> err
          return state

  , onNewPlayer: \args state -> return state

  , onClose: onClose
  }

onClose :: ServerCallback {pId::PlayerId}
onClose args state = do
  let conns = filter (\c -> args.pId /= c.pId) state.connections
  let state' = state { connections = conns }
  trace $ "closed connection for player " <> show args.pId
  return state'

waitingCallbacks =
  ServerCallbacks
    { step: stepWaiting
    , onMessage: onMessageWaiting
    , onNewPlayer: onNewPlayerWaiting
    , onClose: onClose
    }

stepWaiting :: ServerCallback {}
stepWaiting args state = do
  let m = state ^. gameWaiting
  if readyToStart m
    then do
      trace "all players are ready; starting game"
      let game = makeGame (M.keys m)
      sendUpdates state [GameStarting game]
      return $ state
        { gameState = InProgress { game: game, input: M.empty }
        , callbacks = inProgressCallbacks
        }
    else
      return state
  where
  minPlayers = 2
  readyToStart m =
    let ps = M.values m
    in length ps >= minPlayers && all id ps

onMessageWaiting args state =
  case (eitherDecode args.msg :: E.Either String Boolean) of
    E.Right isReady -> do
      trace $ "updated ready state for " <> show args.pId <>
                ": " <> show isReady
      let m = state ^. gameWaiting
      let m' = M.insert args.pId isReady m
      return $ state { gameState = WaitingForPlayers m' }
      {-- return $ state # (gameWaiting .. at args.pId) .~ isReady --}
    E.Left err -> do
      trace $ "failed to parse message: " <> err
      return state

onNewPlayerWaiting :: ServerCallback {pId::PlayerId}
onNewPlayerWaiting args state = return state

sendUpdates :: forall e a. (ToJSON a) =>
  ServerState
  -> [a]
  -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdates state updates = do
  for_ updates $ \update ->
    for_ state.connections $ \c ->
      sendUpdate c.wsConn update

sendUpdate :: forall e a. (ToJSON a) =>
  WS.Connection -> a -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdate conn update =
  WS.send conn $ encode update

foreign import data Process :: !

foreign import chdir
  """
  function chdir(path) {
    return function() {
      process.chdir(path)
    }
  }
  """ :: forall e. String -> Eff (process :: Process | e) Unit

foreign import getEnvImpl
  """
  function getEnvImpl(just, nothing, key) {
    return function() {
      var v = process.env[key]
      return v ? just(v) : nothing
    }
  }
  """ :: forall e a.
  Fn3
    (a -> Maybe a)
    (Maybe a)
    String
    (Eff (process :: Process | e) (Maybe String))

getEnv :: forall e.
  String -> Eff (process :: Process | e) (Maybe String)
getEnv key =
  runFn3 getEnvImpl Just Nothing key

parseNumber :: String -> Maybe Number
parseNumber = decode

portOrDefault :: forall e.
  Number -> Eff (process :: Process | e) Number
portOrDefault default = do
  port <- getEnv "PORT"
  return $ fromMaybe default (port >>= parseNumber)

module Server where

import Debug.Trace
import Data.Tuple
import Data.JSON
import Data.Function
import Data.Maybe
import Data.Array
import qualified Data.Either as E
import qualified Data.Map as M
import Data.Foldable (for_, all)
import Control.Monad
import Control.Monad.Eff
import Control.Monad.Eff.Ref
import Control.Reactive.Timer
import Control.Lens (lens, (^.), (%~), (.~), at, LensP())

import qualified NodeWebSocket as WS
import qualified NodeHttp as Http
import Types
import Game
import Utils

initialState :: ServerState
initialState =
  { gameState: WaitingForPlayers M.empty
  , connections: []
  , callbacks: waitingCallbacks
  }

stepsPerSecond = 30

main = do
  refState <- newRef initialState

  chdir "static"
  port <- portOrDefault 8080

  httpServer <- createHttpServer
  wsServer <- createWebSocketServer refState

  WS.mount wsServer httpServer
  Http.listen httpServer port
  trace $ "listening on " <> show port <> "..."

  startMainLoop refState

createHttpServer =
  Http.createServer $ \req res -> do
    let path = (Http.getUrl req).pathname
    let reply =
      case path of
          "/"           -> Http.sendFile "index.html"
          "/js/game.js" -> Http.sendFile "js/game.js"
          _             -> Http.send404
    reply res

createWebSocketServer refState = do
  server <- WS.mkServer
  WS.onRequest server $ \req -> do
    trace "got a request"
    conn <- WS.accept req

    maybePId <- tryAddPlayer conn refState "harry" -- TODO: actual name

    case maybePId of
      Just pId -> do
        trace $ "opened connection for player " <> show pId
        runCallback refState (\c -> c.onNewPlayer) {pId:pId}

        WS.onMessage conn $ \msg ->
          runCallback refState (\c -> c.onMessage) {msg:msg, pId:pId}
        WS.onClose   conn $ \close ->
          runCallback refState (\c -> c.onClose) {pId:pId}
      Nothing -> do
        trace "rejecting connection, no player ids available"
        WS.close conn

  return server

runCallback refState callback args = do
  state <- readRef refState
  let sc = unwrapServerCallbacks state.callbacks
  state' <- callback sc args state
  writeRef refState state'

startMainLoop refState =
  void $ interval (1000 / stepsPerSecond) $
    runCallback refState (\c -> c.step) {}

tryAddPlayer conn refState name = do
  state <- readRef refState
  case getNextPlayerId state of
    Just pId -> do
      let state' = state { connections =
                            state.connections <>
                              [{ pId: pId, wsConn: conn, name: name }] }
      writeRef refState state'
      return (Just pId)
    Nothing ->
      return Nothing

getNextPlayerId :: ServerState -> Maybe PlayerId
getNextPlayerId state =
  let playerIdsInUse = map (\c -> c.pId) state.connections
  in  head $ allPlayerIds \\ playerIdsInUse

gameInProgress :: LensP ServerState GameStateInProgress
gameInProgress = lens
  (\s -> case s.gameState of
    InProgress x -> x
    _ -> error "gameInProgress: expected game to be in progress")
  (\s x -> s { gameState = InProgress x })

gameWaiting :: LensP ServerState GameStateWaitingForPlayers
gameWaiting = lens
  (\s -> case s.gameState of
    WaitingForPlayers x -> x
    _ -> error "gameWaiting: expected game to be waiting for players")
  (\s x -> s { gameState = WaitingForPlayers x })

inProgressCallbacks =
  ServerCallbacks
  { step: \args state -> do
      let g = state ^. gameInProgress
      let r = stepGame g.input g.game
      let game' = fst r
      let updates = snd r
      sendUpdates state updates
      return $ state
        { gameState = InProgress { game: game', input: M.empty }}

  , onMessage: \args state -> do
      case (eitherDecode args.msg :: E.Either String Direction) of
        E.Right newDir -> do
          {-- return $ state # gameInProgress %~ \g -> --}
          {--   let newInput = M.insert args.pId (Just newDir) g.input --}
          {--   in  {game: g.game, input: newInput} --}
          let g = state ^. gameInProgress
          let newInput = M.insert args.pId (Just newDir) g.input
          return $ state
              { gameState = InProgress { game: g.game, input: newInput }}
        E.Left err -> do
          trace $ "failed to parse message: " <> err
          return state

  , onNewPlayer: \args state -> return state

  , onClose: onClose
  }

onClose :: ServerCallback {pId::PlayerId}
onClose args state = do
  let conns = filter (\c -> args.pId /= c.pId) state.connections
  let state' = state { connections = conns }
  trace $ "closed connection for player " <> show args.pId
  return state'

waitingCallbacks =
  ServerCallbacks
    { step: stepWaiting
    , onMessage: onMessageWaiting
    , onNewPlayer: onNewPlayerWaiting
    , onClose: onClose
    }

stepWaiting :: ServerCallback {}
stepWaiting args state = do
  let m = state ^. gameWaiting
  if readyToStart m
    then do
      trace "all players are ready; starting game"
      let game = makeGame (M.keys m)
      sendUpdates state [GameStarting game]
      return $ state
        { gameState = InProgress { game: game, input: M.empty }
        , callbacks = inProgressCallbacks
        }
    else
      return state
  where
  minPlayers = 2
  readyToStart m =
    let ps = M.values m
    in length ps >= minPlayers && all id ps

onMessageWaiting args state =
  case (eitherDecode args.msg :: E.Either String Boolean) of
    E.Right isReady -> do
      let m = state ^. gameWaiting
      let m' = M.insert args.pId isReady m
      return $ state { gameState = WaitingForPlayers m' }
      {-- return $ state # (gameWaiting .. at args.pId) .~ isReady --}
    E.Left err -> do
      trace $ "failed to parse message: " <> err
      return state

onNewPlayerWaiting :: ServerCallback {pId::PlayerId}
onNewPlayerWaiting args state = return state

sendUpdates :: forall e a. (ToJSON a) =>
  ServerState
  -> [a]
  -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdates state updates = do
  for_ updates $ \update ->
    for_ state.connections $ \c ->
      sendUpdate c.wsConn update

sendUpdate :: forall e a. (ToJSON a) =>
  WS.Connection -> a -> Eff (ws :: WS.WebSocket | e) Unit
sendUpdate conn update =
  WS.send conn $ encode update

foreign import data Process :: !

foreign import chdir
  """
  function chdir(path) {
    return function() {
      process.chdir(path)
    }
  }
  """ :: forall e. String -> Eff (process :: Process | e) Unit

foreign import getEnvImpl
  """
  function getEnvImpl(just, nothing, key) {
    return function() {
      var v = process.env[key]
      return v ? just(v) : nothing
    }
  }
  """ :: forall e a.
  Fn3
    (a -> Maybe a)
    (Maybe a)
    String
    (Eff (process :: Process | e) (Maybe String))

getEnv :: forall e.
  String -> Eff (process :: Process | e) (Maybe String)
getEnv key =
  runFn3 getEnvImpl Just Nothing key

parseNumber :: String -> Maybe Number
parseNumber = decode

portOrDefault :: forall e.
  Number -> Eff (process :: Process | e) Number
portOrDefault default = do
  port <- getEnv "PORT"
  return $ fromMaybe default (port >>= parseNumber)


remove some really stupid 3AM code

remove some really stupid 3AM code

module Main where

import Prelude
import Data.Foreign.Generic as DFG
import Control.IxMonad (ibind, (:*>), (:>>=))
import Control.Monad.Aff (Canceler, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Except (runExcept)
import Data.Array (sortBy)
import Data.Either (Either(..))
import Data.Foreign.Class (class IsForeign, readJSON, write)
import Data.Generic.Rep (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst, snd)
import Global.Unsafe (unsafeStringify)
import Hyper.Middleware (lift')
import Hyper.Middleware.Class (getConn)
import Hyper.Node.FileServer (fileServer)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Request (readBody)
import Hyper.Response (headers, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusNotFound, statusOK)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, defaultSpawnOptions, spawn)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.FS.Aff (readdir, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Process (PROCESS, lookupEnv)
import SQLite3 (DBConnection, DBEffects, newDB, queryDB)

newtype OpenRequest = OpenRequest
  { path :: String
  }
derive instance grOR :: Generic OpenRequest _
instance ifOR :: IsForeign OpenRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype UpdateRequest = UpdateRequest
  { path :: String
  , watched :: Boolean
  }
derive instance grUR :: Generic UpdateRequest _
instance ifUR :: IsForeign UpdateRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype Config = Config
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff )

main :: forall eff.
  Eff (AppEffects (err :: EXCEPTION | eff))
    (Canceler (AppEffects eff))
main = launchAff $
  (liftEff $ lookupEnv "FILETRACKER_DIR") >>=
  case _ of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- newDB $ concat [dir, "filetracker"]
      let config = Config {db, dir}
      liftEff $ runServer options config router
  where
    router = getConn :>>= handleConn
    options = defaultOptions { onListening = onListening, onRequestError = onRequestError}
    onListening port = log $ "listening on " <> (show $ unwrap port)
    onRequestError error = log $ "error: " <> show error
    notFound =
      writeStatus statusNotFound
      :*> headers []
      :*> respond (Tuple "
Not Found
" UTF8)
    respondJSON json =
      writeStatus statusOK
      :*> headers [Tuple "Content-Type" "application/json"]
      :*> respond json
    readFiles path = lift' $ unsafeStringify <<< write <$> readdir'
      where
        readdir' = do
          withStats <- traverse pairWithStat =<< readdir path
          pure $ fst <$> sortByDate withStats
        pairWithStat file = do
          s <- stat $ concat [path, file]
          pure (Tuple file s)
        sortByDate = sortBy <<< flip $ comparing (modifiedTime <<< snd)
    handleConn conn@{components: Config {dir, db}} =
      case Tuple conn.request.method conn.request.url of
        Tuple (Left GET) "/api/files" -> files
        Tuple (Left GET) "/api/watched" -> watched
        Tuple (Left POST) "/api/update" -> update
        Tuple (Left POST) "/api/open" -> open
        _ -> fileServer "dist" notFound
        where
          bind = ibind
          files = readFiles dir :>>= respondJSON
          open = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (OpenRequest or) -> do
                _ <- liftEff $ spawn "explorer" (pure $ concat [dir, or.path]) defaultSpawnOptions
                respondJSON "{}"
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          queryDB' query params = lift' $ queryDB db query params
          update = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (UpdateRequest ur) -> do
                _ <- if ur.watched
                  then queryDB' "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [ur.path]
                  else queryDB' "DELETE FROM watched WHERE path = $1" [ur.path]
                watched
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          watched = do
            -- should come back as [{path :: String, created :: String}]
            -- demand refund if not
            a <- queryDB' "SELECT path, created FROM watched;" []
            respondJSON $ unsafeStringify a

module Main where

import Prelude
import Data.Foreign.Generic as DFG
import Control.IxMonad (ibind, (:*>), (:>>=))
import Control.Monad.Aff (Canceler, launchAff)
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Console (error)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Except (runExcept)
import Data.Array (sortBy)
import Data.Either (Either(..))
import Data.Foreign.Class (class IsForeign, readJSON, write)
import Data.Generic.Rep (class Generic)
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(Tuple), fst)
import Global.Unsafe (unsafeStringify)
import Hyper.Middleware (lift')
import Hyper.Middleware.Class (getConn)
import Hyper.Node.FileServer (fileServer)
import Hyper.Node.Server (defaultOptions, runServer)
import Hyper.Request (readBody)
import Hyper.Response (headers, respond, writeStatus)
import Hyper.Status (statusBadRequest, statusNotFound, statusOK)
import Node.Buffer (BUFFER)
import Node.ChildProcess (CHILD_PROCESS, defaultSpawnOptions, spawn)
import Node.Encoding (Encoding(UTF8))
import Node.FS (FS)
import Node.FS.Aff (readdir, stat)
import Node.FS.Stats (modifiedTime)
import Node.HTTP (HTTP)
import Node.Path (concat)
import Node.Process (PROCESS, lookupEnv)
import SQLite3 (DBConnection, DBEffects, newDB, queryDB)

newtype OpenRequest = OpenRequest
  { path :: String
  }
derive instance grOR :: Generic OpenRequest _
instance ifOR :: IsForeign OpenRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype UpdateRequest = UpdateRequest
  { path :: String
  , watched :: Boolean
  }
derive instance grUR :: Generic UpdateRequest _
instance ifUR :: IsForeign UpdateRequest where
  read = DFG.readGeneric $ DFG.defaultOptions {unwrapSingleConstructors = true}

newtype Config = Config
  { db :: DBConnection
  , dir :: String
  }

type AppEffects eff =
  ( avar :: AVAR
  , console :: CONSOLE
  , db :: DBEffects
  , process :: PROCESS
  , cp :: CHILD_PROCESS
  , http :: HTTP
  , fs :: FS
  , buffer :: BUFFER
  | eff )

main :: forall eff.
  Eff (AppEffects (err :: EXCEPTION | eff))
    (Canceler (AppEffects eff))
main = launchAff $
  (liftEff $ lookupEnv "FILETRACKER_DIR") >>=
  case _ of
    Nothing -> error "we done broke now!!!!"
    Just dir -> do
      db <- newDB $ concat [dir, "filetracker"]
      let config = Config {db, dir}
      liftEff $ runServer options config router
  where
    router = getConn :>>= handleConn
    options = defaultOptions { onListening = onListening, onRequestError = onRequestError}
    onListening port = log $ "listening on " <> (show $ unwrap port)
    onRequestError error = log $ "error: " <> show error
    notFound =
      writeStatus statusNotFound
      :*> headers []
      :*> respond (Tuple "
Not Found
" UTF8)
    respondJSON json =
      writeStatus statusOK
      :*> headers [Tuple "Content-Type" "application/json"]
      :*> respond json
    readFiles path = lift' $ unsafeStringify <<< write <$> readdir'
      where
        readdir' = do
          withStats <- traverse pairWithStat =<< readdir path
          pure $ fst <$> sortByDate withStats
        pairWithStat file = do
          s <- stat $ concat [path, file]
          pure (Tuple file s)
        sortByDate = sortBy compareDates
        compareDates (Tuple _ a) (Tuple _ b) =
          compare EQ $ compare (modifiedTime a) (modifiedTime b)
    handleConn conn@{components: Config {dir, db}} =
      case Tuple conn.request.method conn.request.url of
        Tuple (Left GET) "/api/files" -> files
        Tuple (Left GET) "/api/watched" -> watched
        Tuple (Left POST) "/api/update" -> update
        Tuple (Left POST) "/api/open" -> open
        _ -> fileServer "dist" notFound
        where
          bind = ibind
          files = readFiles dir :>>= respondJSON
          open = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (OpenRequest or) -> do
                _ <- liftEff $ spawn "explorer" (pure $ concat [dir, or.path]) defaultSpawnOptions
                respondJSON "{}"
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          queryDB' query params = lift' $ queryDB db query params
          update = do
            body <- readBody
            case runExcept $ readJSON body of
              Right (UpdateRequest ur) -> do
                _ <- if ur.watched
                  then queryDB' "INSERT OR REPLACE INTO watched (path, created) VALUES ($1, datetime());" [ur.path]
                  else queryDB' "DELETE FROM watched WHERE path = $1" [ur.path]
                watched
              Left e -> do
                writeStatus statusBadRequest
                headers []
                respond $ "you gave me bad JSON!!!\n" <> show e <> "\nin\n" <> body
          watched = do
            -- should come back as [{path :: String, created :: String}]
            -- demand refund if not
            a <- queryDB' "SELECT path, created FROM watched;" []
            respondJSON $ unsafeStringify a


eliminated some unnecessary lambdas

eliminated some unnecessary lambdas

module Main where

{-- import Data.DOM.Simple.Window --}
{-- import Data.DOM.Simple.Document --}
{-- import Data.DOM.Simple.Element --}
import Control.Monad.Eff
import Data.Array
import Data.Foldable
import Data.Maybe
import Debug.Trace

import Types
import Transformer
import Isomer

ts :: [Transformer]
ts = [
       tStackEqual
     , tReplace Red Blue
     , tTail
     ]

initial :: Wall
initial = [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]]

cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

mapIndexed :: forall a b. (Number -> a -> b) -> [a] -> [b]
mapIndexed f xs = zipWith f (0 .. (length xs - 1)) xs

renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer y x stack =
    sequence_ $ mapIndexed (renderCube isomer x (-6 * y)) $ map cubeColor stack

renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    sequence_ $ mapIndexed (\x stack -> renderStack isomer y (length wall - x) stack) (reverse wall)

renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls =
    sequence_ $ mapIndexed (renderWall isomer) walls

main = do
    trace $ "Initial: " ++ (show initial)
    trace "Steps:"
    let steps = allSteps ts initial
    traverse_ (show >>> trace) steps
    trace "---"
    trace ""

    {-- doc <- document globalWindow --}
    {-- Just el <- querySelector "#targetshape" doc --}
    {-- setInnerHTML "lkasjd" el --}

    isomer <- getIsomerInstance "canvas"
    setIsomerConfig isomer 40 40 400

    {-- renderWall isomer initial --}
    renderWalls isomer steps

module Main where

{-- import Data.DOM.Simple.Window --}
{-- import Data.DOM.Simple.Document --}
{-- import Data.DOM.Simple.Element --}
import Control.Monad.Eff
import Data.Array
import Data.Foldable
import Data.Maybe
import Debug.Trace

import Types
import Transformer
import Isomer

ts :: [Transformer]
ts = [
       tStackEqual
     , tReplace Red Blue
     , tTail
     ]

initial :: Wall
initial = [[Brown], [Orange], [Orange], [Yellow], [Yellow], [Yellow], [Orange], [Orange], [Brown]]

cubeColor :: Cube -> IsomerColor
cubeColor Blue = colorFromRGB 0 160 176
cubeColor Brown = colorFromRGB 106 74 60
cubeColor Red = colorFromRGB 204 51 63
cubeColor Orange = colorFromRGB 235 104 65
cubeColor Yellow = colorFromRGB 237 201 81

mapIndexed :: forall a b. (a -> Number -> b) -> [a] -> [b]
mapIndexed f xs = zipWith f xs (0 .. (length xs - 1))

renderStack :: forall eff. IsomerInstance -> Number -> Number -> Stack -> Eff (isomer :: Isomer | eff) Unit
renderStack isomer x y stack =
    sequence_ $ mapIndexed (\cube z -> renderCube isomer x (-6 * y) z (cubeColor cube)) stack

renderWall :: forall eff. IsomerInstance -> Number -> Wall -> Eff (isomer :: Isomer | eff) Unit
renderWall isomer y wall =
    sequence_ $ mapIndexed (\stack x -> renderStack isomer (length wall - x) y stack) (reverse wall)

renderWalls :: forall eff. IsomerInstance -> [Wall] -> Eff (isomer :: Isomer | eff) Unit
renderWalls isomer walls =
    sequence_ $ mapIndexed (\wall y -> renderWall isomer y wall) walls

main = do
    trace $ "Initial: " ++ (show initial)
    trace "Steps:"
    let steps = allSteps ts initial
    traverse_ (show >>> trace) steps
    trace "---"
    trace ""

    {-- doc <- document globalWindow --}
    {-- Just el <- querySelector "#targetshape" doc --}
    {-- setInnerHTML "lkasjd" el --}

    isomer <- getIsomerInstance "canvas"
    setIsomerConfig isomer 40 40 400

    {-- renderWall isomer initial --}
    renderWalls isomer steps


Removed duplicate rate equation methods.

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

-- | State of the camera. Yaw is anticlockwise rotation in radians about the positive y axis, pitch is anticlockwise rotation in radians about the
-- | positive x axis after it has been transformed for the yaw. At zero pitch and zero yaw, the camera points in the negative z direction.
newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | The rate equation!
applyRate :: Number -> Seconds -> Number
applyRate v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 0.1

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: true, a: true, d: true, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: true, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: true}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: true}) = i3
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * applyRate angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale (applyRate movementRate stepSeconds) $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw - dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p

-- | Pure functions and types representing the (pretty simple) state of the simulation
module Jundo.Simulation (
  RotationDirection(..),
  SimulationState(..),
  CameraState(..),
  CubeState(..),
  KeyboardState(..),
  MouseMove(..),
  initialSimulationState,
  applyMouseMove,
  timestep,
  toggleDirection
  ) where

import Prelude
import Jundo.Vectors
import Data.Time (Milliseconds(..), Seconds(..), toSeconds)
import Data.Vector
import Data.Vector3
import Math

type RadiansPerSecond = Number
type MetersPerSecond = Number

data RotationDirection = Clockwise | Anticlockwise

instance showRotationDirection :: Show RotationDirection where
  show Clockwise = "Clockwise"
  show Anticlockwise = "Anticlockwise"

newtype CubeState = CubeState {direction :: RotationDirection, angle :: Radians, position :: Vec3 Number}

instance showCubeState :: Show CubeState where
  show (CubeState s) = "CubeState {direction: " ++ show s.direction ++ ", angle: " ++ show s.angle ++ ", position: " ++ show s.position ++ "}"

-- | State of the camera. Yaw is anticlockwise rotation in radians about the positive y axis, pitch is anticlockwise rotation in radians about the
-- | positive x axis after it has been transformed for the yaw. At zero pitch and zero yaw, the camera points in the negative z direction.
newtype CameraState = CameraState {yaw :: Radians, pitch :: Radians, position :: Vec3 Number}

instance showCameraState :: Show CameraState where
  show (CameraState s) = " CameraState {yaw: " ++ show s.yaw ++ ", pitch: " ++ show s.pitch ++ ", position: " ++ show s.position ++ "}"

newtype SimulationState = SimulationState {cube :: CubeState, camera :: CameraState}

instance showSimulationState :: Show SimulationState where
  show (SimulationState s) = "SimulationState {camera: " ++ show s.camera ++ ", cube: " ++ show s.cube ++ "}"

mapCameraState :: (CameraState -> CameraState) -> SimulationState -> SimulationState
mapCameraState f (SimulationState s) = SimulationState {cube: s.cube, camera: f s.camera}

mapCubeState :: (CubeState -> CubeState) -> SimulationState -> SimulationState
mapCubeState f (SimulationState s) = SimulationState {cube: f s.cube, camera: s.camera}

initialSimulationState :: SimulationState
initialSimulationState = SimulationState {
  cube: CubeState {direction: Anticlockwise, angle: 0.0, position: vec3 0.0 0.0 (-6.0)},
  camera: CameraState {pitch: 0.0, yaw: 0.0, position: vec3 0.0 0.0 0.0}
  }

-- | Type for tracking which keys are currently depressed
newtype KeyboardState = KeyboardState {w :: Boolean, a :: Boolean, s :: Boolean, d :: Boolean}

instance showKeyboardState :: Show KeyboardState where
  show (KeyboardState s) = "KeyboardState {w: " ++ show s.w ++ ", a: " ++ show s.a ++ ", s: " ++ show s.s ++ ", d: " ++ show s.d ++ "}"

-- | Rotation speed of the cube
angularSpeed :: RadiansPerSecond
angularSpeed = 1.0

-- | Angle change is velocity multiplied by time
angleFromVelocity :: RadiansPerSecond -> Seconds -> Radians
angleFromVelocity v (Seconds t) = v * t

-- | Distance is speed multiplied by time
distanceFromVelocity :: MetersPerSecond -> Seconds -> Number
distanceFromVelocity v (Seconds t) = v * t

-- | Camera movement rate
movementRate :: MetersPerSecond
movementRate = 0.1

-- | Convert the keyboard state into a unit vector in the direction of movement if the camera was pointing in the -z direction
cameraUnitVelocity :: KeyboardState -> Vec3 Number
cameraUnitVelocity (KeyboardState {w: true, a: false, d: false, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: false, d: false, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: false}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: false}) = i3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: false}) = vec3 (-sqrt1_2) 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: false}) = vec3 sqrt1_2 0.0 (-sqrt1_2)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: false, s: true}) = vec3 (-sqrt1_2) 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: false, a: false, d: true, s: true}) = vec3 sqrt1_2 0.0 sqrt1_2
cameraUnitVelocity (KeyboardState {w: true, a: true, d: true, s: false}) = vec3 0.0 0.0 (-1.0)
cameraUnitVelocity (KeyboardState {w: false, a: true, d: true, s: true}) = k3
cameraUnitVelocity (KeyboardState {w: true, a: true, d: false, s: true}) = vec3 (-1.0) 0.0 0.0
cameraUnitVelocity (KeyboardState {w: true, a: false, d: true, s: true}) = i3
cameraUnitVelocity _ = vec3 0.0 0.0 0.0

-- | Update the simulation state to reflect a change in simulation time, applying camera and cube movement
timestep :: Milliseconds -> KeyboardState -> SimulationState -> SimulationState
timestep step ks simulationState = mapCubeState updateCube $ mapCameraState updateCamera simulationState
  where
  stepSeconds :: Seconds
  stepSeconds = toSeconds step
  updateCube :: CubeState -> CubeState
  updateCube (CubeState cs) = CubeState {direction: cs.direction, position: cs.position, angle: cs.angle + angleChange cs.direction}
    where
    angleChange direction = directionMultiplier * angleFromVelocity angularSpeed stepSeconds
    directionMultiplier = case cs.direction of
      Anticlockwise -> 1.0
      Clockwise -> -1.0
  updateCamera :: CameraState -> CameraState
  updateCamera (CameraState cs) = CameraState {pitch: cs.pitch, yaw: cs.yaw, position: vAdd cs.position positionChange}
    where
    positionChange = scale (distanceFromVelocity movementRate stepSeconds) $ rotateVec3 j3 cs.yaw (cameraUnitVelocity ks)

-- | Make the cube spin the other way! Excitement.
toggleDirection :: SimulationState -> SimulationState
toggleDirection = mapCubeState (\(CubeState s) -> CubeState {direction: newDirection s.direction, angle: s.angle, position: s.position})
  where
  newDirection d = case d of
    Clockwise -> Anticlockwise
    Anticlockwise -> Clockwise

-- | Type representing a change in mouse position (x y)
data MouseMove = MouseMove Number Number

instance showMouseMove :: Show MouseMove where
  show (MouseMove dx dy) = "MouseMove (" ++ show dx ++ ", " ++ show dy ++ ")"

-- | Radians of pitch change per unit mouse movement
pitchSensitivity :: Radians
pitchSensitivity = 0.01

-- | Radians of yaw change per unit mouse movement
yawSensitivity :: Radians
yawSensitivity = 0.01

-- | Apply a change in mouse position to the simulation state
applyMouseMove :: MouseMove -> SimulationState -> SimulationState
applyMouseMove (MouseMove dx dy) = mapCameraState \(CameraState cs) -> CameraState {
  pitch: ensurePitch $ cs.pitch + dy * pitchSensitivity,
  yaw: cs.yaw - dx * yawSensitivity,
  position: cs.position
  }
  where
  -- Pitch must be between -0.5 pi and 0.5 pi
  ensurePitch :: Radians -> Radians
  ensurePitch p | p < -0.5 * pi = -0.5 * pi
  ensurePitch p | p > 0.5 * pi = 0.5 * pi
  ensurePitch p = p


obtain all points by eating a player

obtain all points by eating a player

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Arrow
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 240

-- minimum squared distance that a player needs to be from another player in
-- order to eat them, in blocks.
minEatingQuadrance = 4

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p) -> pPosition .~ p
    (ChangedDirection d) -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s) -> pScore .~ s
    (ChangedNomIndex a) -> pNomIndex .~ a
    (ChangedIsEaten x) -> pIsEaten .~ x

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

changeIsEaten :: PlayerId -> Boolean -> GameUpdateM Unit
changeIsEaten pId x =
  applyGameUpdateM (GUPU pId (ChangedIsEaten x))

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe (Tuple PlayerId Number) -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap safeZone bigDots
  , countdown: Just 90
  , rampage: Nothing
  , safeZone: safeZone
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  safeZone = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      eachPlayer eatOtherPlayers
      eachPlayer unEatSelf
      decrementRampageCounter
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection pId p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

isRampage :: PlayerId -> GameUpdateM Boolean
isRampage pId =
  (\g -> maybe false (fst >>> (==) pId) g.rampage) <$> getGame

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  when (not (p ^. pIsEaten)) $ do
    let mItem = lookupItemByPosition (p ^. pPosition) g
    whenJust mItem $ \(Tuple iId item) -> do
      case item ^. iType of
        LittleDot -> do
          eat iId
          changeScore pId (p ^. pScore + 1)
        BigDot ->
          when (not (isJust g.rampage)) $ do
            eat iId
            changeScore pId (p ^. pScore + 5)
            startRampage pId

eatOtherPlayers :: PlayerId -> Player -> GameUpdateM Unit
eatOtherPlayers pId p = do
  ok <- isRampage pId
  when ok $ do
    eachPlayer $ \pId' p' ->
      when (pId' /= pId) $ do
        let q = quadrance (p ^. pPosition) (p' ^. pPosition)
        when (q <= minEatingQuadrance) $
          changeIsEaten pId' true
          changeScore pId $ p ^. pScore + p' ^. pScore
          changeScore pId' 0

decrementRampageCounter :: GameUpdateM Unit
decrementRampageCounter = do
  g <- getGame
  whenJust g.rampage $ \(Tuple pId counter) ->
    changeRampage (Tuple pId <$> decrementOrNothing counter)

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ pId ~ rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection pId p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: PlayerId -> Player -> Direction -> GameUpdateM Boolean
canMoveInDirection pId (Player p) d =
  let newPosition = moveInDirection d p.position
      destIsFree game  = isFree game.map newPosition
      immobilised game = not p.isEaten && isFleeing game
      isFleeing game   = maybe false (\(Tuple pId' count) ->
                                pId' /= pId && isOdd count) game.rampage
      both (Tuple x y) = x && y
  in  both <<< (destIsFree &&& (not <<< immobilised)) <$> getGame

unEatSelf :: PlayerId -> Player -> GameUpdateM Unit
unEatSelf pId p = do
  g <- getGame
  when (p ^. pIsEaten && inSafeZone g (p ^. pPosition)) $ do
    changeIsEaten pId false

inSafeZone :: Game -> Position -> Boolean
inSafeZone g pos = pos `elem` g.safeZone

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap safeZone bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos safeZone) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items                         = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x

module Game where

import Data.Tuple
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Array ((!!), range, filter, length, take)
import qualified Data.Map as M
import Data.Foldable
import Control.Arrow
import Control.Alt
import Control.Monad
import Control.Monad.Reader.Class
import Control.Lens (LensP(), TraversalP(), lens, at, _Just, _1, _2,
                     (.~), (..), (^.), (%~), (~))
import Math (ceil, floor, pi)

import Types
import LevelMap
import Utils

minPlayers = 2
rampageLength = 240

-- minimum squared distance that a player needs to be from another player in
-- order to eat them, in blocks.
minEatingQuadrance = 4

-- update signalling

player :: PlayerId -> TraversalP Game Player
player pId = players .. at pId .. _Just

item :: ItemId -> TraversalP Game Item
item iId = items .. at iId .. _Just

applyGameUpdate :: GameUpdate -> Game -> Game
applyGameUpdate u =
  case u of
    GUPU pId PlayerLeft ->
      removePlayer pId
    GUPU pId x ->
      player pId %~ applyPlayerUpdate x
    GUIU iId x ->
      items .. at iId %~ applyItemUpdate x
    ChangedCountdown x ->
      setCountdown x
    GameEnded _ ->
      id
    ChangedRampage r ->
      \g -> g { rampage = r }
  where
  setCountdown x game = game {countdown = x}

applyGameUpdates :: [GameUpdate] -> Game -> Game
applyGameUpdates updates game = foldr applyGameUpdate game updates

removePlayer :: PlayerId -> Game -> Game
removePlayer pId = players .. at pId .~ Nothing

applyPlayerUpdate :: PlayerUpdate -> Player -> Player
applyPlayerUpdate u =
  case u of
    (ChangedPosition p) -> pPosition .~ p
    (ChangedDirection d) -> pDirection .~ d
    (ChangedIntendedDirection d) -> pIntendedDirection .~ d
    (ChangedScore s) -> pScore .~ s
    (ChangedNomIndex a) -> pNomIndex .~ a
    (ChangedIsEaten x) -> pIsEaten .~ x

applyItemUpdate :: ItemUpdate -> Maybe Item -> Maybe Item
applyItemUpdate u =
  case u of
    Eaten -> const Nothing

applyGameUpdateM :: GameUpdate -> GameUpdateM Unit
applyGameUpdateM update = do
  tellGameUpdate update
  modifyGame (applyGameUpdate update)

changePosition :: PlayerId -> Position -> GameUpdateM Unit
changePosition pId p =
  applyGameUpdateM (GUPU pId (ChangedPosition p))

changeDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedDirection d))

changeIntendedDirection :: PlayerId -> Maybe Direction -> GameUpdateM Unit
changeIntendedDirection pId d =
  applyGameUpdateM (GUPU pId (ChangedIntendedDirection d))

changeScore :: PlayerId -> Number -> GameUpdateM Unit
changeScore pId s =
  applyGameUpdateM (GUPU pId (ChangedScore s))

changeCountdown :: Maybe Number -> GameUpdateM Unit
changeCountdown =
  applyGameUpdateM <<< ChangedCountdown

changeNomIndex :: PlayerId -> Number -> GameUpdateM Unit
changeNomIndex pId i =
  applyGameUpdateM (GUPU pId (ChangedNomIndex i))

eat :: ItemId -> GameUpdateM Unit
eat iId =
  applyGameUpdateM (GUIU iId Eaten)

changeIsEaten :: PlayerId -> Boolean -> GameUpdateM Unit
changeIsEaten pId x =
  applyGameUpdateM (GUPU pId (ChangedIsEaten x))

endGame :: GameEndReason -> GameUpdateM Unit
endGame =
  applyGameUpdateM <<< GameEnded

changeRampage :: Maybe (Tuple PlayerId Number) -> GameUpdateM Unit
changeRampage =
  applyGameUpdateM <<< ChangedRampage

initialGame :: Game
initialGame =
  { map: levelmap
  , players: M.fromList $ f <$> starts
  , items:   M.fromList $ zipNumbers $ makeItems levelmap safeZone bigDots
  , countdown: Just 90
  , rampage: Nothing
  , safeZone: safeZone
  }
  where
  levelmap = basicMap2
  f (Tuple pId position) = Tuple pId (mkPlayer position)
  starts =
    [ P1 ~ tilePositionToBlock (Position {x:7, y:7})
    , P2 ~ tilePositionToBlock (Position {x:9, y:7})
    , P3 ~ tilePositionToBlock (Position {x:7, y:8})
    , P4 ~ tilePositionToBlock (Position {x:9, y:8})
    ]
  safeZone = do
    x <- [7,8,9]
    y <- [6,7,8,9]
    return (tilePositionToBlock (Position {x:x, y:y}))
  bigDots = do
    x <- [3, tilesAlongSide - 4]
    y <- [3, tilesAlongSide - 4]
    return (tilePositionToBlock (Position {x:x, y:y}))

stepGame :: Input -> Game -> Tuple Game [GameUpdate]
stepGame input game =
  let actions = [handleInput input, doLogic]
      action = foldl (>>) (return unit) actions
  in  execGameUpdateM game action

handleInput :: Input -> GameUpdateM Unit
handleInput input =
  for_ (M.toList input) $ \(Tuple pId maybeDir) ->
    whenJust maybeDir $ \newDirection ->
      changeIntendedDirection pId (Just newDirection)

doLogic :: GameUpdateM Unit
doLogic = do
  g <- getGame
  case g.countdown of
    Just x -> changeCountdown (decrementOrNothing x)
    Nothing -> do
      eachPlayer updateDirection
      eachPlayer movePlayer
      eachPlayer eatItems
      eachPlayer eatOtherPlayers
      eachPlayer unEatSelf
      decrementRampageCounter
      checkForGameEnd

decrementOrNothing x =
  let x' = x - 1
  in if x' <= 0
        then Nothing
        else Just x'

updateDirection :: PlayerId -> Player -> GameUpdateM Unit
updateDirection pId p =
  whenJust (p ^.pIntendedDirection) $ tryChangeDirection pId p

movePlayer :: PlayerId -> Player -> GameUpdateM Unit
movePlayer pId p =
  whenJust (p ^. pDirection) $ \dir -> do
    ok <- canMoveInDirection pId p dir
    when ok $ do
      changePosition pId $ moveInDirection dir (p ^. pPosition)
      changeNomIndex pId $ ((p ^. pNomIndex) + 1) % nomIndexMax

isRampage :: PlayerId -> GameUpdateM Boolean
isRampage pId =
  (\g -> maybe false (fst >>> (==) pId) g.rampage) <$> getGame

eatItems :: PlayerId -> Player -> GameUpdateM Unit
eatItems pId p = do
  g <- getGame
  when (not (p ^. pIsEaten)) $ do
    let mItem = lookupItemByPosition (p ^. pPosition) g
    whenJust mItem $ \(Tuple iId item) -> do
      case item ^. iType of
        LittleDot -> do
          eat iId
          changeScore pId (p ^. pScore + 1)
        BigDot ->
          when (not (isJust g.rampage)) $ do
            eat iId
            changeScore pId (p ^. pScore + 5)
            startRampage pId

eatOtherPlayers :: PlayerId -> Player -> GameUpdateM Unit
eatOtherPlayers pId p = do
  ok <- isRampage pId
  when ok $ do
    eachPlayer $ \pId' p' ->
      when (pId' /= pId) $ do
        let q = quadrance (p ^. pPosition) (p' ^. pPosition)
        when (q <= minEatingQuadrance) $
          changeIsEaten pId' true

decrementRampageCounter :: GameUpdateM Unit
decrementRampageCounter = do
  g <- getGame
  whenJust g.rampage $ \(Tuple pId counter) ->
    changeRampage (Tuple pId <$> decrementOrNothing counter)

startRampage :: PlayerId -> GameUpdateM Unit
startRampage pId =
  changeRampage $ Just $ pId ~ rampageLength

checkForGameEnd :: GameUpdateM Unit
checkForGameEnd = do
  g <- getGame
  whenJust (checkEnded g) endGame

tryChangeDirection :: PlayerId -> Player -> Direction -> GameUpdateM Unit
tryChangeDirection pId p d = do
  ok <- canMoveInDirection pId p d
  when ok $ do
    changeDirection pId (Just d)
    changeIntendedDirection pId Nothing

canMoveInDirection :: PlayerId -> Player -> Direction -> GameUpdateM Boolean
canMoveInDirection pId (Player p) d =
  let newPosition = moveInDirection d p.position
      destIsFree game  = isFree game.map newPosition
      immobilised game = not p.isEaten && isFleeing game
      isFleeing game   = maybe false (\(Tuple pId' count) ->
                                pId' /= pId && isOdd count) game.rampage
      both (Tuple x y) = x && y
  in  both <<< (destIsFree &&& (not <<< immobilised)) <$> getGame

unEatSelf :: PlayerId -> Player -> GameUpdateM Unit
unEatSelf pId p = do
  g <- getGame
  when (p ^. pIsEaten && inSafeZone g (p ^. pPosition)) $ do
    changeIsEaten pId false

inSafeZone :: Game -> Position -> Boolean
inSafeZone g pos = pos `elem` g.safeZone

moveInDirection :: Direction -> Position -> Position
moveInDirection d p = add p (dirToPos d)

isFree :: LevelMap -> Position -> Boolean
isFree levelmap pos =
  let block = getBlockAt pos levelmap
  in  maybe false (not <<< isWall) block

makeItems :: LevelMap -> [Position] -> [Position] -> [Item]
makeItems levelmap safeZone bigDotPositions =
  littleDots <> bigDots
  where
  littleDots = do
    x <- r
    y <- r
    let pos = tilePositionToBlock (Position {x: x, y: y})
    if shouldHaveLittleDot pos
      then [Item { itemType: LittleDot, position: pos }]
      else []

  r = range 0 (tilesAlongSide - 1)

  shouldHaveLittleDot pos =
    isFree levelmap pos &&
      not (elem pos safeZone) &&
      not (elem pos bigDotPositions)

  bigDots =
    (\pos -> Item { itemType: BigDot, position: pos }) <$> bigDotPositions

makeGame :: [PlayerId] -> Game
makeGame pIds =
  let players' =
    deleteWhere (\pId _ -> not (elem pId pIds)) (initialGame.players)
  in initialGame { players = players' }

inCountdown :: Game -> Boolean
inCountdown g = isJust g.countdown

checkEnded :: Game -> Maybe GameEndReason
checkEnded g
  | M.isEmpty g.items                         = Just Completed
  | length (M.values g.players) < minPlayers  = Just TooManyPlayersDisconnected
  | otherwise                                 = Nothing

isEnded = isJust <<< checkEnded

-- TODO: performance
lookupItemByPosition :: Position -> Game -> Maybe (Tuple ItemId Item)
lookupItemByPosition pos g =
  case filter (\i -> (i ^. _2 ^. iPosition) == pos) (M.toList g.items) of
      [i] -> Just i
      []  -> Nothing
      x   -> error $ "lookupItemByPosition: items stacked: " <> show x


Fix bad import

Fix bad import

Signed-off-by: Ricky Elrod <3de8762d49a778edd8b1aa9f381ea5a9ccb62944@elrod.me>

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 41.714754626155 (-73.726791873574)
  roadmap <- gMap mapE (MapOptions { zoom: 6, center: startingPoint, mapTypeId: "roadmap" })
  randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  panTo roadmap randomcoord

  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)
  testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  pushMVCArray mvcA testcoord
  pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: randomcoord, map: roadmap, title: "HABP Location" })
  iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://127.0.0.1:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> updateMap x mvcA polyline marker)
  --sendWS socket example

  nowMoment <- now
  let leet = momentConstructor "January 1, 0678"
  let leet' = createMoment leet
  Just lastupdate <- getElementById "lastupdate" doc
  let str = liftMoment2 momentFrom nowMoment <$> leet'
  let seven = fromMaybe "Unknown" str
  setInnerHTML seven lastupdate

  trace "hi"
  where
    updateMap e mvcA polyline marker = do
      trace "RX from websocket"
      msgData <- getData e
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          trace $ unsafeShowJSON result
          case result.coordinates of
            Coordinate coord -> do
              latestLatLng <- newLatLng coord.latitude coord.longitude
              pushMVCArray mvcA latestLatLng
              setPolylinePath polyline mvcA
              setMarkerPosition marker latestLatLng

module Main where

import Control.Monad.Eff
import Data.DOM.Simple.Ajax
import Data.DOM.Simple.Document
import Data.DOM.Simple.Element
import Data.DOM.Simple.Encode
import Data.DOM.Simple.Events hiding (read)
import Data.DOM.Simple.Types
import Data.DOM.Simple.Window
import Data.Either
import Data.Foreign
import Data.Foreign.Class
import Data.Maybe
import Debug.Trace
import DomHelpers hiding (setInnerHtml)
import GMaps.InfoWindow
import GMaps.LatLng
import GMaps.Map
import GMaps.MapOptions
import GMaps.Marker
import GMaps.MVCArray
import GMaps.Polyline
import MapViewWS
import MomentJS
import WebSocket

setDismissAnnouncement :: forall eff. HTMLDocument -> Eff (dom :: DOM | eff) Unit
setDismissAnnouncement doc = do
  -- TODO: Partial
  Just dismissButton <- getElementById "dismiss_announcement" doc
  Just announcement <- getElementById "announcement" doc
  y <- setDisplayFn announcement "none"
  setOnclick dismissButton y

setAnnouncement :: forall eff. HTMLDocument -> String -> String -> Eff (dom :: DOM | eff) Unit
setAnnouncement doc t c = do
  -- TODO: Partial
  Just announcement <- getElementById "announcement" doc
  Just text <- getElementById "announcement_text" doc
  setInnerHTML t text
  setClass announcement c
  setDisplay announcement "block"

foreign import getData
  "function getData(x) {\
  \  return function() {\
  \    return x.data;\
  \  };\
  \}" :: forall eff. Event -> Eff eff String

main = do
  doc <- document globalWindow
  setDismissAnnouncement doc
  Just mapE <- getElementById "map-canvas" doc
  startingPoint <- newLatLng 41.714754626155 (-73.726791873574)
  roadmap <- gMap mapE (MapOptions { zoom: 6, center: startingPoint, mapTypeId: "roadmap" })
  randomcoord <- newLatLng 41.714754626155 (-73.726791873574)
  panTo roadmap randomcoord

  mvcA <- newMVCArray :: forall eff. Eff eff (MVCArray LatLng)
  testcoord <- newLatLng 41.714754626155 (-73.726791873574)
  pushMVCArray mvcA testcoord
  pushMVCArray mvcA randomcoord

  polyline <- newPolyline (PolylineOptions { geodescic: true
                                           , strokeColor: "#ff0000"
                                           , strokeOpacity: 1.0
                                           , strokeWeight: 2
                                           , map: roadmap
                                           })
  setPolylinePath polyline mvcA

  marker <- newMarker (MarkerOptions { position: randomcoord, map: roadmap, title: "HABP Location" })
  iw <- newInfoWindow (InfoWindowOptions { content: "HABP Location" })
  openInfoWindow iw roadmap marker

  --let example = "{\"coordinates\":{\"latitude\":43.714754626155,\"longitude\":-64.726791873574},\"altitude\":300,\"time\":\"1234321\"}"
  socket <- newWebSocket "ws://127.0.0.1:9160/"
  addEventListenerWS socket "onmessage" $ (\x -> updateMap x mvcA polyline marker)
  --sendWS socket example

  nowMoment <- now
  let leet = momentConstructor "January 1, 0678"
  let leet' = createMoment leet
  Just lastupdate <- getElementById "lastupdate" doc
  let str = liftMoment2 momentFrom nowMoment <$> leet'
  let seven = fromMaybe "Unknown" str
  setInnerHTML seven lastupdate

  trace "hi"
  where
    updateMap e mvcA polyline marker = do
      trace "RX from websocket"
      msgData <- getData e
      case readJSON msgData :: F WSMessage of
        Left err -> trace $ "Error parsing JSON:\n" ++ show err
        Right (LocationBeacon result) -> do
          trace $ unsafeShowJSON result
          case result.coordinates of
            Coordinate coord -> do
              latestLatLng <- newLatLng coord.latitude coord.longitude
              pushMVCArray mvcA latestLatLng
              setPolylinePath polyline mvcA
              setMarkerPosition marker latestLatLng