provide ord instance for map

provide ord instance for map

-- | This module defines a type of maps as balanced 2-3 trees, based on
-- | <http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf>

module Data.Map
  ( Map(),
    showTree,
    empty,
    isEmpty,
    singleton,
    checkValid,
    insert,
    lookup,
    toList,
    fromList,
    fromListWith,
    delete,
    member,
    alter,
    update,
    keys,
    values,
    union,
    unionWith,
    unions,
    map,
    size
  ) where

import qualified Data.Array as A
import Data.Maybe
import Data.Tuple
import Data.Monoid (Monoid)
import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.Traversable (traverse, Traversable)

-- | `Map k v` represents maps from keys of type `k` to values of type `v`.
data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where
  (==) m1 m2 = toList m1 == toList m2
  (/=) m1 m2 = not (m1 == m2)

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "fromList " ++ show (toList m)

instance ordMap :: (Ord k, Ord v) => Ord (Map k v) where
  compare m1 m2 = compare (toList m1) (toList m2)

instance semigroupMap :: (Ord k) => Semigroup (Map k v) where
  (<>) = union

instance monoidMap :: (Ord k) => Monoid (Map k v) where
  mempty = empty

instance functorMap :: Functor (Map k) where
  (<$>) _ Leaf = Leaf
  (<$>) f (Two left k v right) = Two (f <$> left) k (f v) (f <$> right)
  (<$>) f (Three left k1 v1 mid k2 v2 right) = Three (f <$> left) k1 (f v1) (f <$> mid) k2 (f v2) (f <$> right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: (Ord k) => Traversable (Map k) where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) (((<$>) (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- | Render a `Map` as a `String`
showTree :: forall k v. (Show k, Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" ++ showTree left ++
  ") (" ++ show k ++
  ") (" ++ show v ++
  ") (" ++ showTree right ++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" ++ showTree left ++
  ") (" ++ show k1 ++
  ") (" ++ show v1 ++
  ") (" ++ showTree mid ++
  ") (" ++ show k2 ++
  ") (" ++ show v2 ++
  ") (" ++ showTree right ++ ")"

-- | An empty map
empty :: forall k v. Map k v
empty = Leaf

-- | Test if a map is empty
isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

-- | Create a map with one key/value pair
singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

-- | Check whether the underlying tree satisfies the 2-3 invariant
-- |
-- | This function is provided for internal use.
checkValid :: forall k v. Map k v -> Boolean
checkValid tree = A.length (A.nub (allHeights tree)) == 1
  where
  allHeights :: forall k v. Map k v -> [Number]
  allHeights Leaf = [0]
  allHeights (Two left _ _ right) = A.map (\n -> n + 1) (allHeights left ++ allHeights right)
  allHeights (Three left _ _ mid _ _ right) = A.map (\n -> n + 1) (allHeights left ++ allHeights mid ++ allHeights right)

-- | Lookup a value for the specified key
lookup :: forall k v. (Ord k) => k -> Map k v -> Maybe v
lookup _ Leaf = Nothing
lookup k (Two _ k1 v _) | k == k1 = Just v
lookup k (Two left k1 _ _) | k < k1 = lookup k left
lookup k (Two _ _ _ right) = lookup k right
lookup k (Three _ k1 v1 _ _ _ _) | k == k1 = Just v1
lookup k (Three _ _ _ _ k2 v2 _) | k == k2 = Just v2
lookup k (Three left k1 _ _ _ _ _) | k < k1 = lookup k left
lookup k (Three _ k1 _ mid k2 _ _) | k1 < k && k <= k2 = lookup k mid
lookup k (Three _ _ _ _ _ _ right) = lookup k right

-- | Test if a key is a member of a map
member :: forall k v. (Ord k) => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (Ord k) => [TreeContext k v] -> Map k v -> Map k v
fromZipper [] tree = tree
fromZipper (TwoLeft k1 v1 right : ctx) left = fromZipper ctx (Two left k1 v1 right)
fromZipper (TwoRight left k1 v1 : ctx) right = fromZipper ctx (Two left k1 v1 right)
fromZipper (ThreeLeft k1 v1 mid k2 v2 right : ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeMiddle left k1 v1 k2 v2 right : ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeRight left k1 v1 mid k2 v2 : ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)

data KickUp k v = KickUp (Map k v) k v (Map k v)

-- | Insert a key/value pair into a map
insert :: forall k v. (Ord k) => k -> v -> Map k v -> Map k v
insert = down []
  where
  down :: forall k v. (Ord k) => [TreeContext k v] -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 _ right) | k == k1 = fromZipper ctx (Two left k v right)
  down ctx k v (Two left k1 v1 right) | k < k1 = down (TwoLeft k1 v1 right : ctx) k v left
  down ctx k v (Two left k1 v1 right) = down (TwoRight left k1 v1 : ctx) k v right
  down ctx k v (Three left k1 _ mid k2 v2 right) | k == k1 = fromZipper ctx (Three left k v mid k2 v2 right)
  down ctx k v (Three left k1 v1 mid k2 _ right) | k == k2 = fromZipper ctx (Three left k1 v1 mid k v right)
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k < k1 = down (ThreeLeft k1 v1 mid k2 v2 right : ctx) k v left
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 < k && k <= k2 = down (ThreeMiddle left k1 v1 k2 v2 right : ctx) k v mid
  down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 : ctx) k v right

  up :: forall k v. (Ord k) => [TreeContext k v] -> KickUp k v -> Map k v
  up [] (KickUp left k v right) = Two left k v right
  up (TwoLeft k1 v1 right : ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
  up (TwoRight left k1 v1 : ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
  up (ThreeLeft k1 v1 c k2 v2 d : ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
  up (ThreeMiddle a k1 v1 k2 v2 d : ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
  up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

-- | Delete a key and its corresponding value from a map
delete :: forall k v. (Ord k) => k -> Map k v -> Map k v
delete = down []
  where
  down :: forall k v. (Ord k) => [TreeContext k v] -> k -> Map k v -> Map k v
  down ctx _ Leaf = fromZipper ctx Leaf
  down ctx k (Two Leaf k1 _ Leaf)
    | k == k1 = up ctx Leaf
  down ctx k (Two left k1 v1 right)
    | k == k1   = let max = maxNode left
                    in removeMaxNode (TwoLeft max.key max.value right : ctx) left
    | k < k1    = down (TwoLeft k1 v1 right : ctx) k left
    | otherwise = down (TwoRight left k1 v1 : ctx) k right
  down ctx k (Three Leaf k1 v1 Leaf k2 v2 Leaf)
    | k == k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
    | k == k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
  down ctx k (Three left k1 v1 mid k2 v2 right)
    | k == k1 = let max = maxNode left
                  in removeMaxNode (ThreeLeft max.key max.value mid k2 v2 right : ctx) left
    | k == k2 = let max = maxNode mid
                  in removeMaxNode (ThreeMiddle left k1 v1 max.key max.value right : ctx) mid
    | k < k1               = down (ThreeLeft k1 v1 mid k2 v2 right : ctx) k left
    | k1 < k && k < k2 = down (ThreeMiddle left k1 v1 k2 v2 right : ctx) k mid
    | otherwise            = down (ThreeRight left k1 v1 mid k2 v2 : ctx) k right

  up :: forall k v. (Ord k) => [TreeContext k v] -> Map k v -> Map k v
  up [] tree = tree
  up (TwoLeft k1 v1 Leaf : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoRight Leaf k1 v1 : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoLeft k1 v1 (Two m k2 v2 r) : ctx) l = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoRight (Two l k1 v1 m) k2 v2 : ctx) r = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d) : ctx) a = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (TwoRight (Three a k1 v1 b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (ThreeLeft k1 v1 Leaf k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeMiddle Leaf k1 v1 k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeRight Leaf k1 v1 Leaf k2 v2 : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d : ctx) a = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d : ctx) c = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d) : ctx) b = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e : ctx) a = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e : ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e) : ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 : ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

  maxNode :: forall k v. (Ord k) => Map k v -> { key :: k, value :: v }
  maxNode (Two _ k v Leaf) = { key: k, value: v }
  maxNode (Two _ _ _ right) = maxNode right
  maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
  maxNode (Three _ _ _ _ _ _ right) = maxNode right

  removeMaxNode :: forall k v. (Ord k) => [TreeContext k v] -> Map k v -> Map k v
  removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
  removeMaxNode ctx (Two left k v right) = removeMaxNode (TwoRight left k v : ctx) right
  removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (TwoRight Leaf k1 v1 : ctx) Leaf
  removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (ThreeRight left k1 v1 mid k2 v2 : ctx) right

-- | Insert the value, delete a value, or update a value for a key in a map
alter :: forall k v. (Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Update or delete the value for a key in a map
update :: forall k v. (Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

-- | Convert a map to an array of key/value pairs
toList :: forall k v. Map k v -> [Tuple k v]
toList Leaf = []
toList (Two left k v right) = toList left ++ [Tuple k v] ++ toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left ++ [Tuple k1 v1] ++ toList mid ++ [Tuple k2 v2] ++ toList right

-- | Create a map from an array of key/value pairs
fromList :: forall k v. (Ord k) => [Tuple k v] -> Map k v
fromList = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Create a map from an array of key/value pairs, using the specified function
-- | to combine values for duplicate keys.
fromListWith :: forall k v. (Ord k) => (v -> v -> v) -> [Tuple k v] -> Map k v
fromListWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where
  combine v (Just v') = Just $ f v v'
  combine v Nothing = Just v

-- | Get an array of the keys contained in a map
keys :: forall k v. Map k v -> [k]
keys Leaf = []
keys (Two left k _ right) = keys left ++ [k] ++ keys right
keys (Three left k1 _ mid k2 _ right) = keys left ++ [k1] ++ keys mid ++ [k2] ++ keys right

-- | Get an array of the values contained in a map
values :: forall k v. Map k v -> [v]
values Leaf = []
values (Two left _ v right) = values left ++ [v] ++ values right
values (Three left _ v1 mid _ v2 right) = values left ++ [v1] ++ values mid ++ [v2] ++ values right

-- | Compute the union of two maps, using the specified function
-- | to combine values for duplicate keys.
unionWith :: forall k v. (Ord k) => (v -> v -> v) -> Map k v -> Map k v -> Map k v
unionWith f m1 m2 = foldl go m2 (toList m1)
  where
  go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m

-- | Compute the union of two maps, preferring values from the first map in the case
-- | of duplicate keys
union :: forall k v. (Ord k) => Map k v -> Map k v -> Map k v
union = unionWith const

-- | Compute the union of a collection of maps
unions :: forall k v. (Ord k) => [Map k v] -> Map k v
unions = foldl union empty

-- | Apply a function to the values in a map
map :: forall k a b. (a -> b) -> Map k a -> Map k b
map = (<$>)

-- | Calculate the number of key/value pairs in a map
size :: forall k v. Map k v -> Number
size = A.length <<< values

-- | This module defines a type of maps as balanced 2-3 trees, based on
-- | <http://www.cs.princeton.edu/~dpw/courses/cos326-12/ass/2-3-trees.pdf>

module Data.Map
  ( Map(),
    showTree,
    empty,
    isEmpty,
    singleton,
    checkValid,
    insert,
    lookup,
    toList,
    fromList,
    fromListWith,
    delete,
    member,
    alter,
    update,
    keys,
    values,
    union,
    unionWith,
    unions,
    map,
    size
  ) where

import qualified Data.Array as A
import Data.Maybe
import Data.Tuple
import Data.Monoid (Monoid)
import Data.Foldable (foldl, foldMap, foldr, Foldable)
import Data.Traversable (traverse, Traversable)

-- | `Map k v` represents maps from keys of type `k` to values of type `v`.
data Map k v
  = Leaf
  | Two (Map k v) k v (Map k v)
  | Three (Map k v) k v (Map k v) k v (Map k v)

instance eqMap :: (Eq k, Eq v) => Eq (Map k v) where
  (==) m1 m2 = toList m1 == toList m2
  (/=) m1 m2 = not (m1 == m2)

instance showMap :: (Show k, Show v) => Show (Map k v) where
  show m = "fromList " ++ show (toList m)

instance semigroupMap :: (Ord k) => Semigroup (Map k v) where
  (<>) = union

instance monoidMap :: (Ord k) => Monoid (Map k v) where
  mempty = empty

instance functorMap :: Functor (Map k) where
  (<$>) _ Leaf = Leaf
  (<$>) f (Two left k v right) = Two (f <$> left) k (f v) (f <$> right)
  (<$>) f (Three left k1 v1 mid k2 v2 right) = Three (f <$> left) k1 (f v1) (f <$> mid) k2 (f v2) (f <$> right)

instance foldableMap :: Foldable (Map k) where
  foldl   f z m = foldl   f z (values m)
  foldr   f z m = foldr   f z (values m)
  foldMap f   m = foldMap f   (values m)

instance traversableMap :: (Ord k) => Traversable (Map k) where
  traverse f ms = foldr (\x acc -> union <$> x <*> acc) (pure empty) (((<$>) (uncurry singleton)) <$> (traverse f <$> toList ms))
  sequence = traverse id

-- | Render a `Map` as a `String`
showTree :: forall k v. (Show k, Show v) => Map k v -> String
showTree Leaf = "Leaf"
showTree (Two left k v right) =
  "Two (" ++ showTree left ++
  ") (" ++ show k ++
  ") (" ++ show v ++
  ") (" ++ showTree right ++ ")"
showTree (Three left k1 v1 mid k2 v2 right) =
  "Three (" ++ showTree left ++
  ") (" ++ show k1 ++
  ") (" ++ show v1 ++
  ") (" ++ showTree mid ++
  ") (" ++ show k2 ++
  ") (" ++ show v2 ++
  ") (" ++ showTree right ++ ")"

-- | An empty map
empty :: forall k v. Map k v
empty = Leaf

-- | Test if a map is empty
isEmpty :: forall k v. Map k v -> Boolean
isEmpty Leaf = true
isEmpty _ = false

-- | Create a map with one key/value pair
singleton :: forall k v. k -> v -> Map k v
singleton k v = Two Leaf k v Leaf

-- | Check whether the underlying tree satisfies the 2-3 invariant
-- |
-- | This function is provided for internal use.
checkValid :: forall k v. Map k v -> Boolean
checkValid tree = A.length (A.nub (allHeights tree)) == 1
  where
  allHeights :: forall k v. Map k v -> [Number]
  allHeights Leaf = [0]
  allHeights (Two left _ _ right) = A.map (\n -> n + 1) (allHeights left ++ allHeights right)
  allHeights (Three left _ _ mid _ _ right) = A.map (\n -> n + 1) (allHeights left ++ allHeights mid ++ allHeights right)

-- | Lookup a value for the specified key
lookup :: forall k v. (Ord k) => k -> Map k v -> Maybe v
lookup _ Leaf = Nothing
lookup k (Two _ k1 v _) | k == k1 = Just v
lookup k (Two left k1 _ _) | k < k1 = lookup k left
lookup k (Two _ _ _ right) = lookup k right
lookup k (Three _ k1 v1 _ _ _ _) | k == k1 = Just v1
lookup k (Three _ _ _ _ k2 v2 _) | k == k2 = Just v2
lookup k (Three left k1 _ _ _ _ _) | k < k1 = lookup k left
lookup k (Three _ k1 _ mid k2 _ _) | k1 < k && k <= k2 = lookup k mid
lookup k (Three _ _ _ _ _ _ right) = lookup k right

-- | Test if a key is a member of a map
member :: forall k v. (Ord k) => k -> Map k v -> Boolean
member k m = isJust (k `lookup` m)

data TreeContext k v
  = TwoLeft k v (Map k v)
  | TwoRight (Map k v) k v
  | ThreeLeft k v (Map k v) k v (Map k v)
  | ThreeMiddle (Map k v) k v k v (Map k v)
  | ThreeRight (Map k v) k v (Map k v) k v

fromZipper :: forall k v. (Ord k) => [TreeContext k v] -> Map k v -> Map k v
fromZipper [] tree = tree
fromZipper (TwoLeft k1 v1 right : ctx) left = fromZipper ctx (Two left k1 v1 right)
fromZipper (TwoRight left k1 v1 : ctx) right = fromZipper ctx (Two left k1 v1 right)
fromZipper (ThreeLeft k1 v1 mid k2 v2 right : ctx) left = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeMiddle left k1 v1 k2 v2 right : ctx) mid = fromZipper ctx (Three left k1 v1 mid k2 v2 right)
fromZipper (ThreeRight left k1 v1 mid k2 v2 : ctx) right = fromZipper ctx (Three left k1 v1 mid k2 v2 right)

data KickUp k v = KickUp (Map k v) k v (Map k v)

-- | Insert a key/value pair into a map
insert :: forall k v. (Ord k) => k -> v -> Map k v -> Map k v
insert = down []
  where
  down :: forall k v. (Ord k) => [TreeContext k v] -> k -> v -> Map k v -> Map k v
  down ctx k v Leaf = up ctx (KickUp Leaf k v Leaf)
  down ctx k v (Two left k1 _ right) | k == k1 = fromZipper ctx (Two left k v right)
  down ctx k v (Two left k1 v1 right) | k < k1 = down (TwoLeft k1 v1 right : ctx) k v left
  down ctx k v (Two left k1 v1 right) = down (TwoRight left k1 v1 : ctx) k v right
  down ctx k v (Three left k1 _ mid k2 v2 right) | k == k1 = fromZipper ctx (Three left k v mid k2 v2 right)
  down ctx k v (Three left k1 v1 mid k2 _ right) | k == k2 = fromZipper ctx (Three left k1 v1 mid k v right)
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k < k1 = down (ThreeLeft k1 v1 mid k2 v2 right : ctx) k v left
  down ctx k v (Three left k1 v1 mid k2 v2 right) | k1 < k && k <= k2 = down (ThreeMiddle left k1 v1 k2 v2 right : ctx) k v mid
  down ctx k v (Three left k1 v1 mid k2 v2 right) = down (ThreeRight left k1 v1 mid k2 v2 : ctx) k v right

  up :: forall k v. (Ord k) => [TreeContext k v] -> KickUp k v -> Map k v
  up [] (KickUp left k v right) = Two left k v right
  up (TwoLeft k1 v1 right : ctx) (KickUp left k v mid) = fromZipper ctx (Three left k v mid k1 v1 right)
  up (TwoRight left k1 v1 : ctx) (KickUp mid k v right) = fromZipper ctx (Three left k1 v1 mid k v right)
  up (ThreeLeft k1 v1 c k2 v2 d : ctx) (KickUp a k v b) = up ctx (KickUp (Two a k v b) k1 v1 (Two c k2 v2 d))
  up (ThreeMiddle a k1 v1 k2 v2 d : ctx) (KickUp b k v c) = up ctx (KickUp (Two a k1 v1 b) k v (Two c k2 v2 d))
  up (ThreeRight a k1 v1 b k2 v2 : ctx) (KickUp c k v d) = up ctx (KickUp (Two a k1 v1 b) k2 v2 (Two c k v d))

-- | Delete a key and its corresponding value from a map
delete :: forall k v. (Ord k) => k -> Map k v -> Map k v
delete = down []
  where
  down :: forall k v. (Ord k) => [TreeContext k v] -> k -> Map k v -> Map k v
  down ctx _ Leaf = fromZipper ctx Leaf
  down ctx k (Two Leaf k1 _ Leaf)
    | k == k1 = up ctx Leaf
  down ctx k (Two left k1 v1 right)
    | k == k1   = let max = maxNode left
                    in removeMaxNode (TwoLeft max.key max.value right : ctx) left
    | k < k1    = down (TwoLeft k1 v1 right : ctx) k left
    | otherwise = down (TwoRight left k1 v1 : ctx) k right
  down ctx k (Three Leaf k1 v1 Leaf k2 v2 Leaf)
    | k == k1 = fromZipper ctx (Two Leaf k2 v2 Leaf)
    | k == k2 = fromZipper ctx (Two Leaf k1 v1 Leaf)
  down ctx k (Three left k1 v1 mid k2 v2 right)
    | k == k1 = let max = maxNode left
                  in removeMaxNode (ThreeLeft max.key max.value mid k2 v2 right : ctx) left
    | k == k2 = let max = maxNode mid
                  in removeMaxNode (ThreeMiddle left k1 v1 max.key max.value right : ctx) mid
    | k < k1               = down (ThreeLeft k1 v1 mid k2 v2 right : ctx) k left
    | k1 < k && k < k2 = down (ThreeMiddle left k1 v1 k2 v2 right : ctx) k mid
    | otherwise            = down (ThreeRight left k1 v1 mid k2 v2 : ctx) k right

  up :: forall k v. (Ord k) => [TreeContext k v] -> Map k v -> Map k v
  up [] tree = tree
  up (TwoLeft k1 v1 Leaf : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoRight Leaf k1 v1 : ctx) Leaf = fromZipper ctx (Two Leaf k1 v1 Leaf)
  up (TwoLeft k1 v1 (Two m k2 v2 r) : ctx) l = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoRight (Two l k1 v1 m) k2 v2 : ctx) r = up ctx (Three l k1 v1 m k2 v2 r)
  up (TwoLeft k1 v1 (Three b k2 v2 c k3 v3 d) : ctx) a = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (TwoRight (Three a k1 v1 b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two (Two a k1 v1 b) k2 v2 (Two c k3 v3 d))
  up (ThreeLeft k1 v1 Leaf k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeMiddle Leaf k1 v1 k2 v2 Leaf : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeRight Leaf k1 v1 Leaf k2 v2 : ctx) Leaf = fromZipper ctx (Three Leaf k1 v1 Leaf k2 v2 Leaf)
  up (ThreeLeft k1 v1 (Two b k2 v2 c) k3 v3 d : ctx) a = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle (Two a k1 v1 b) k2 v2 k3 v3 d : ctx) c = fromZipper ctx (Two (Three a k1 v1 b k2 v2 c) k3 v3 d)
  up (ThreeMiddle a k1 v1 k2 v2 (Two c k3 v3 d) : ctx) b = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeRight a k1 v1 (Two b k2 v2 c) k3 v3 : ctx) d = fromZipper ctx (Two a k1 v1 (Three b k2 v2 c k3 v3 d))
  up (ThreeLeft k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 e : ctx) a = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle (Three a k1 v1 b k2 v2 c) k3 v3 k4 v4 e : ctx) d = fromZipper ctx (Three (Two a k1 v1 b) k2 v2 (Two c k3 v3 d) k4 v4 e)
  up (ThreeMiddle a k1 v1 k2 v2 (Three c k3 v3 d k4 v4 e) : ctx) b = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))
  up (ThreeRight a k1 v1 (Three b k2 v2 c k3 v3 d) k4 v4 : ctx) e = fromZipper ctx (Three a k1 v1 (Two b k2 v2 c) k3 v3 (Two d k4 v4 e))

  maxNode :: forall k v. (Ord k) => Map k v -> { key :: k, value :: v }
  maxNode (Two _ k v Leaf) = { key: k, value: v }
  maxNode (Two _ _ _ right) = maxNode right
  maxNode (Three _ _ _ _ k v Leaf) = { key: k, value: v }
  maxNode (Three _ _ _ _ _ _ right) = maxNode right

  removeMaxNode :: forall k v. (Ord k) => [TreeContext k v] -> Map k v -> Map k v
  removeMaxNode ctx (Two Leaf _ _ Leaf) = up ctx Leaf
  removeMaxNode ctx (Two left k v right) = removeMaxNode (TwoRight left k v : ctx) right
  removeMaxNode ctx (Three Leaf k1 v1 Leaf _ _ Leaf) = up (TwoRight Leaf k1 v1 : ctx) Leaf
  removeMaxNode ctx (Three left k1 v1 mid k2 v2 right) = removeMaxNode (ThreeRight left k1 v1 mid k2 v2 : ctx) right

-- | Insert the value, delete a value, or update a value for a key in a map
alter :: forall k v. (Ord k) => (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
alter f k m = case f (k `lookup` m) of
  Nothing -> delete k m
  Just v -> insert k v m

-- | Update or delete the value for a key in a map
update :: forall k v. (Ord k) => (v -> Maybe v) -> k -> Map k v -> Map k v
update f k m = alter (maybe Nothing f) k m

-- | Convert a map to an array of key/value pairs
toList :: forall k v. Map k v -> [Tuple k v]
toList Leaf = []
toList (Two left k v right) = toList left ++ [Tuple k v] ++ toList right
toList (Three left k1 v1 mid k2 v2 right) = toList left ++ [Tuple k1 v1] ++ toList mid ++ [Tuple k2 v2] ++ toList right

-- | Create a map from an array of key/value pairs
fromList :: forall k v. (Ord k) => [Tuple k v] -> Map k v
fromList = foldl (\m (Tuple k v) -> insert k v m) empty

-- | Create a map from an array of key/value pairs, using the specified function
-- | to combine values for duplicate keys.
fromListWith :: forall k v. (Ord k) => (v -> v -> v) -> [Tuple k v] -> Map k v
fromListWith f = foldl (\m (Tuple k v) -> alter (combine v) k m) empty where
  combine v (Just v') = Just $ f v v'
  combine v Nothing = Just v

-- | Get an array of the keys contained in a map
keys :: forall k v. Map k v -> [k]
keys Leaf = []
keys (Two left k _ right) = keys left ++ [k] ++ keys right
keys (Three left k1 _ mid k2 _ right) = keys left ++ [k1] ++ keys mid ++ [k2] ++ keys right

-- | Get an array of the values contained in a map
values :: forall k v. Map k v -> [v]
values Leaf = []
values (Two left _ v right) = values left ++ [v] ++ values right
values (Three left _ v1 mid _ v2 right) = values left ++ [v1] ++ values mid ++ [v2] ++ values right

-- | Compute the union of two maps, using the specified function
-- | to combine values for duplicate keys.
unionWith :: forall k v. (Ord k) => (v -> v -> v) -> Map k v -> Map k v -> Map k v
unionWith f m1 m2 = foldl go m2 (toList m1)
  where
  go m (Tuple k v) = alter (Just <<< maybe v (f v)) k m

-- | Compute the union of two maps, preferring values from the first map in the case
-- | of duplicate keys
union :: forall k v. (Ord k) => Map k v -> Map k v -> Map k v
union = unionWith const

-- | Compute the union of a collection of maps
unions :: forall k v. (Ord k) => [Map k v] -> Map k v
unions = foldl union empty

-- | Apply a function to the values in a map
map :: forall k a b. (a -> b) -> Map k a -> Map k b
map = (<$>)

-- | Calculate the number of key/value pairs in a map
size :: forall k v. Map k v -> Number
size = A.length <<< values


shrink around center points too

shrink around center points too

module App.Geometry where

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

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

ptAngle :: Point -> Point -> Radians
ptAngle (Point x1 y1) (Point x2 y2) =
  atan2 (y2 - y1) (x2 - x1)

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 (ptAngle c p) (ptAngle c q) ccw

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

distance :: Point -> Point -> Number
distance (Point x1 y1) (Point x2 y2) = sqrt (pow (x1 - x2) 2.0 + pow (y1 - y2) 2.0)

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 (distance p p1) < (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)
          <> (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

outboundAngle :: Stroke -> Radians
outboundAngle (Line (Point x1 y1) (Point x2 y2)) =
  atan2 (y2 - y1) (x2 - x1)
outboundAngle (Arc c p _ ccw) =
  let a = ptAngle c p
   in 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 = 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 = (distance c p)
   in if ccw then 1.0 / r else - 1.0 / r

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) * (distance c p)

-- clockwise rotation -> positive angle
-- ->/ == negative
-- ->\ == positive
-- TODO: what if we do a 180? (currently should never happen due to simplify)
angleDiff :: Stroke -> Stroke -> Radians
angleDiff strokeFrom strokeTo =
  atan2Radians (outboundAngle strokeTo - inboundAngle strokeFrom)

findWrap :: Path -> Radians
findWrap Nil = 0.0
findWrap path@(_ : rest) =
  foldl (+) 0.0 (angles <> (sweep <$> path))
  where
    angles = zipWith angleDiff path rest

flipStroke :: Stroke -> Stroke
flipStroke (Line p1 p2) = Line p2 p1
flipStroke (Arc c p q ccw) = (Arc c q p (not 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 (ptAngle c p) (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 = 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 = 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 = distance c1 p1
      r2 = distance c2 p2
      d = 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

insertSplitStroke ::  Stroke -> Path -> Intersections -> Intersections
insertSplitStroke  stroke splitStroke intersections =
  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 -> 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

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) =
      insertSplitStroke edge (split edge points) i

    intersections = foldl insertPoints empty shrunkTuples
  in
    insertSplitStroke stroke (split stroke (concatMap snd shrunkTuples)) intersections

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.List (List(..), concatMap, filter, foldl, head, length, mapMaybe, nub, reverse, singleton, snoc, sort, sortBy, zipWith, (:))
import Data.Map (Map, empty, insert, lookup, values)
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..), snd)
import Math (Radians, abs, atan2, cos, pi, pow, sin, sqrt)

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

ptAngle :: Point -> Point -> Radians
ptAngle (Point x1 y1) (Point x2 y2) =
  atan2 (y2 - y1) (x2 - x1)

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 (ptAngle c p) (ptAngle c q) ccw

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

distance :: Point -> Point -> Number
distance (Point x1 y1) (Point x2 y2) = sqrt (pow (x1 - x2) 2.0 + pow (y1 - y2) 2.0)

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 (distance p p1) < (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)
          <> (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

outboundAngle :: Stroke -> Radians
outboundAngle (Line (Point x1 y1) (Point x2 y2)) =
  atan2 (y2 - y1) (x2 - x1)
outboundAngle (Arc c p _ ccw) =
  let a = ptAngle c p
   in 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 = 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 = (distance c p)
   in if ccw then 1.0 / r else - 1.0 / r

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) * (distance c p)

-- clockwise rotation -> positive angle
-- ->/ == negative
-- ->\ == positive
-- TODO: what if we do a 180? (currently should never happen due to simplify)
angleDiff :: Stroke -> Stroke -> Radians
angleDiff strokeFrom strokeTo =
  atan2Radians (outboundAngle strokeTo - inboundAngle strokeFrom)

findWrap :: Path -> Radians
findWrap Nil = 0.0
findWrap path@(_ : rest) =
  foldl (+) 0.0 (angles <> (sweep <$> path))
  where
    angles = zipWith angleDiff path rest

flipStroke :: Stroke -> Stroke
flipStroke (Line p1 p2) = Line p2 p1
flipStroke (Arc c p q ccw) = (Arc c q p (not 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 (ptAngle c p) (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 = 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 = 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 = distance c1 p1
      r2 = distance c2 p2
      d = 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

insertSplitStroke ::  Stroke -> Path -> Intersections -> Intersections
insertSplitStroke  stroke splitStroke intersections =
  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 -> 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

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

    -- 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 $ (firstPoint <$> strokes) <> (secondPoint <$> 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) =
      insertSplitStroke edge (split edge points) i

    intersections = foldl insertPoints empty shrunkTuples
  in
    insertSplitStroke stroke (split stroke (concatMap snd shrunkTuples)) intersections

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)


Include reads as well as writes to mustache.js's cache in docs

module Mustache where

import Control.Monad.Eff (Eff())
import Data.StrMap (StrMap())
import Prelude (Show, Unit())

type Template = String

type Tag = String

type View = StrMap String

type Partials = StrMap String

type Token = Array TokenElement

foreign import data TokenElement :: *

foreign import showTokenElementImpl :: TokenElement -> String

instance showTokenElement :: Show TokenElement where
  show = showTokenElementImpl

-- | Effect that represents side effects within mustache.js.
-- |
-- | This is used to indicate interactions with the cache in mustache.js.
foreign import data MustacheEffect :: !

-- | Name of the mustache.js dependency.
foreign import name :: String

-- | Version string as specified in mustache.js.
foreign import version :: String

-- | Default mustache.js tags (default: array with "{{" and "}}").
foreign import tags :: Array Tag

-- | Precompile a template and store parsed token in mustache.js's cache.
foreign import parse :: forall e. Template -> Array Tag -> Eff (mustache :: MustacheEffect | e) (Array Token)

-- | Render the template with the given view and partial templates.
foreign import render :: forall e. Template -> View -> Partials -> Eff (mustache :: MustacheEffect | e) String

-- | Escape various characters as HTML entities in the given string.
foreign import escape :: String -> String

-- | Clear the internal cache used by mustache.js.
foreign import clearCache :: forall e. Eff (mustache :: MustacheEffect | e) Unit

module Mustache where

import Control.Monad.Eff (Eff())
import Data.StrMap (StrMap())
import Prelude (Show, Unit())

type Template = String

type Tag = String

type View = StrMap String

type Partials = StrMap String

type Token = Array TokenElement

foreign import data TokenElement :: *

foreign import showTokenElementImpl :: TokenElement -> String

instance showTokenElement :: Show TokenElement where
  show = showTokenElementImpl

-- | Effect that represents side effects within mustache.js.
-- |
-- | This is used to indicate writes that take place to mustache.js's cache.
foreign import data MustacheEffect :: !

-- | Name of the mustache.js dependency.
foreign import name :: String

-- | Version string as specified in mustache.js.
foreign import version :: String

-- | Default mustache.js tags (default: array with "{{" and "}}").
foreign import tags :: Array Tag

-- | Precompile a template and store parsed token in mustache.js's cache.
foreign import parse :: forall e. Template -> Array Tag -> Eff (mustache :: MustacheEffect | e) (Array Token)

-- | Render the template with the given view and partial templates.
foreign import render :: forall e. Template -> View -> Partials -> Eff (mustache :: MustacheEffect | e) String

-- | Escape various characters as HTML entities in the given string.
foreign import escape :: String -> String

-- | Clear the internal cache used by mustache.js.
foreign import clearCache :: forall e. Eff (mustache :: MustacheEffect | e) Unit


Remove unneeded `do` in Array's Bind explanation

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k -> f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

-- | The `Array` monad works like a nested for loop. Each
-- | `bind`/`>>=` adds another level of nesting in the loop:
-- | ```
-- | foo :: Array Int
-- | foo =
-- |   ["a", "b"] >>= \eachElementInArray1 ->
-- |     ["c", "d"] >>= \eachElementInArray2
-- |       pure (eachElementInArray1 <> eachElementInArray2)
-- |
-- | foo == [ ("a" <> "c"), ("a" <> "d"), ("b" <> "c"), ("b" <> "d") == [ "ac", "ad", "bc", "bd"]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k -> f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class Apply m <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

instance bindFn :: Bind ((->) r) where
  bind m f x = f (m x) x

-- | The `Array` monad works like a nested for loop. Each
-- | `bind`/`>>=` adds another level of nesting in the loop:
-- | ```
-- | foo :: Array Int
-- | foo = do
-- |   ["a", "b"] >>= \eachElementInArray1 ->
-- |     ["c", "d"] >>= \eachElementInArray2
-- |       pure (eachElementInArray1 <> eachElementInArray2)
-- |
-- | foo == [ ("a" <> "c"), ("a" <> "d"), ("b" <> "c"), ("b" <> "d") == [ "ac", "ad", "bc", "bd"]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f