Add 'users/glittershark/xanthous/' from commit '53b56744f4'

git-subtree-dir: users/glittershark/xanthous
git-subtree-mainline: 91f53f02d8
git-subtree-split: 53b56744f4

users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs

@@ -0,0 +1,24 @@
+--------------------------------------------------------------------------------
+module Xanthous.Util.Comonad
+  ( -- * Store comonad utils
+    replace
+  , current
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Control.Comonad.Store.Class
+--------------------------------------------------------------------------------
+
+-- | Replace the current position of a store comonad with a new value by
+-- comparing positions
+replace :: (Eq i, ComonadStore i w) => w a -> a -> w a
+replace w x = w =>> \w' -> if pos w' == pos w then x else extract w'
+{-# INLINE replace #-}
+
+-- | Lens into the current position of a store comonad.
+--
+--     current = lens extract replace
+current :: (Eq i, ComonadStore i w) => Lens' (w a) a
+current = lens extract replace
+{-# INLINE current #-}

users/glittershark/xanthous/src/Xanthous/Util/Graph.hs

@@ -0,0 +1,33 @@
+--------------------------------------------------------------------------------
+module Xanthous.Util.Graph where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Graph.Inductive.Query.MST (msTree)
+import qualified Data.Graph.Inductive.Graph as Graph
+import           Data.Graph.Inductive.Graph
+import           Data.Graph.Inductive.Basic (undir)
+import           Data.Set (isSubsetOf)
+--------------------------------------------------------------------------------
+
+mstSubGraph
+  :: forall gr node edge. (DynGraph gr, Real edge, Show edge)
+  => gr node edge -> gr node edge
+mstSubGraph graph = insEdges mstEdges . insNodes (labNodes graph) $ Graph.empty
+  where
+    mstEdges = ordNub $ do
+      LP path <- msTree $ undir graph
+      case path of
+        [] -> []
+        [_] -> []
+        ((n₂, edgeWeight) : (n₁, _) : _) ->
+          pure (n₁, n₂, edgeWeight)
+
+isSubGraphOf
+  :: (Graph gr1, Graph gr2, Ord node, Ord edge)
+  => gr1 node edge
+  -> gr2 node edge
+  -> Bool
+isSubGraphOf graph₁ graph₂
+  = setFromList (labNodes graph₁) `isSubsetOf` setFromList (labNodes graph₂)
+  && setFromList (labEdges graph₁) `isSubsetOf` setFromList (labEdges graph₂)

users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs

@@ -0,0 +1,174 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- | Graphics algorithms and utils for rendering things in 2D space
+--------------------------------------------------------------------------------
+module Xanthous.Util.Graphics
+  ( circle
+  , filledCircle
+  , line
+  , straightLine
+  , delaunay
+
+    -- * Debugging and testing tools
+  , renderBooleanGraphics
+  , showBooleanGraphics
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+-- https://github.com/noinia/hgeometry/issues/28
+-- import qualified Algorithms.Geometry.DelaunayTriangulation.DivideAndConquer
+--               as Geometry
+import qualified Algorithms.Geometry.DelaunayTriangulation.Naive
+              as Geometry
+import qualified Algorithms.Geometry.DelaunayTriangulation.Types as Geometry
+import           Control.Monad.State (execState, State)
+import qualified Data.Geometry.Point as Geometry
+import           Data.Ext ((:+)(..))
+import           Data.List (unfoldr)
+import           Data.List.NonEmpty (NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NE
+import           Data.Ix (Ix)
+import           Linear.V2
+--------------------------------------------------------------------------------
+
+
+-- | Generate a circle centered at the given point and with the given radius
+-- using the <midpoint circle algorithm
+-- https://en.wikipedia.org/wiki/Midpoint_circle_algorithm>.
+--
+-- Code taken from <https://rosettacode.org/wiki/Bitmap/Midpoint_circle_algorithm#Haskell>
+circle :: (Num i, Ord i)
+       => (i, i) -- ^ center
+       -> i      -- ^ radius
+       -> [(i, i)]
+circle (x₀, y₀) radius
+  -- Four initial points, plus the generated points
+  = (x₀, y₀ + radius) : (x₀, y₀ - radius) : (x₀ + radius, y₀) : (x₀ - radius, y₀) : points
+    where
+      -- Creates the (x, y) octet offsets, then maps them to absolute points in all octets.
+      points = concatMap generatePoints $ unfoldr step initialValues
+
+      generatePoints (x, y)
+        = [ (x₀ `xop` x', y₀ `yop` y')
+          | (x', y') <- [(x, y), (y, x)]
+          , xop <- [(+), (-)]
+          , yop <- [(+), (-)]
+          ]
+
+      initialValues = (1 - radius, 1, (-2) * radius, 0, radius)
+
+      step (f, ddf_x, ddf_y, x, y)
+        | x >= y = Nothing
+        | otherwise = Just ((x', y'), (f', ddf_x', ddf_y', x', y'))
+        where
+          (f', ddf_y', y') | f >= 0 = (f + ddf_y' + ddf_x', ddf_y + 2, y - 1)
+                           | otherwise = (f + ddf_x, ddf_y, y)
+          ddf_x' = ddf_x + 2
+          x' = x + 1
+
+
+data FillState i
+  = FillState
+  { _inCircle :: Bool
+  , _result :: NonEmpty (i, i)
+  }
+makeLenses ''FillState
+
+runFillState :: NonEmpty (i, i) -> State (FillState i) a -> [(i, i)]
+runFillState circumference s
+  = toList
+  . view result
+  . execState s
+  $ FillState False circumference
+
+-- | Generate a *filled* circle centered at the given point and with the given
+-- radius by filling a circle generated with 'circle'
+filledCircle :: (Num i, Integral i, Ix i)
+             => (i, i) -- ^ center
+             -> i      -- ^ radius
+             -> [(i, i)]
+filledCircle origin radius =
+  case NE.nonEmpty (circle origin radius) of
+    Nothing -> []
+    Just circumference -> runFillState circumference $
+      -- the first and last lines of all circles are solid, so the whole "in the
+      -- circle, out of the circle" thing doesn't work... but that's fine since
+      -- we don't need to fill them. So just skip them
+      for_ [succ minX..pred maxX] $ \x ->
+        for_ [minY..maxY] $ \y -> do
+          let pt = (x, y)
+              next = (x, succ y)
+          whenM (use inCircle) $ result %= NE.cons pt
+
+          when (pt `elem` circumference && next `notElem` circumference)
+            $ inCircle %= not
+
+      where
+        ((minX, minY), (maxX, maxY)) = minmaxes circumference
+
+-- | Draw a line between two points using Bresenham's line drawing algorithm
+--
+-- Code taken from <https://wiki.haskell.org/Bresenham%27s_line_drawing_algorithm>
+line :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
+line pa@(xa, ya) pb@(xb, yb)
+  = (if maySwitch pa < maySwitch pb then id else reverse) points
+  where
+    points               = map maySwitch . unfoldr go $ (x₁, y₁, 0)
+    steep                = abs (yb - ya) > abs (xb - xa)
+    maySwitch            = if steep then swap else id
+    [(x₁, y₁), (x₂, y₂)] = sort [maySwitch pa, maySwitch pb]
+    δx                   = x₂ - x₁
+    δy                   = abs (y₂ - y₁)
+    ystep                = if y₁ < y₂ then 1 else -1
+    go (xTemp, yTemp, err)
+      | xTemp > x₂ = Nothing
+      | otherwise  = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
+      where
+        tempError        = err + δy
+        (newY, newError) = if (2 * tempError) >= δx
+                           then (yTemp + ystep, tempError - δx)
+                           else (yTemp, tempError)
+
+straightLine :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
+straightLine pa@(xa, _) pb@(_, yb) = line pa midpoint ++ line midpoint pb
+  where midpoint = (xa, yb)
+
+
+delaunay
+  :: (Ord n, Fractional n)
+  => NonEmpty (V2 n, p)
+  -> [((V2 n, p), (V2 n, p))]
+delaunay
+  = map (over both fromPoint)
+  . Geometry.triangulationEdges
+  . Geometry.delaunayTriangulation
+  . map toPoint
+  where
+    toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid
+    fromPoint (Geometry.Point2 px py :+ pid) = (V2 px py, pid)
+
+--------------------------------------------------------------------------------
+
+renderBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> String
+renderBooleanGraphics [] = ""
+renderBooleanGraphics (pt : pts') = intercalate "\n" rows
+  where
+    rows = row <$> [minX..maxX]
+    row x = [minY..maxY] <&> \y -> if (x, y) `member` ptSet then 'X' else ' '
+    ((minX, minY), (maxX, maxY)) = minmaxes pts
+    pts = pt :| pts'
+    ptSet :: Set (i, i)
+    ptSet = setFromList $ toList pts
+
+showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> IO ()
+showBooleanGraphics = putStrLn . pack . renderBooleanGraphics
+
+minmaxes :: forall i. (Ord i) => NonEmpty (i, i) -> ((i, i), (i, i))
+minmaxes xs =
+    ( ( minimum1Of (traverse1 . _1) xs
+      , minimum1Of (traverse1 . _2) xs
+      )
+    , ( maximum1Of (traverse1 . _1) xs
+      , maximum1Of (traverse1 . _2) xs
+      )
+    )

users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs

@@ -0,0 +1,14 @@
+
+module Xanthous.Util.Inflection
+  ( toSentence
+  ) where
+
+import Xanthous.Prelude
+
+toSentence :: (MonoFoldable mono, Element mono ~ Text) => mono -> Text
+toSentence xs = case reverse . toList $ xs of
+  [] -> ""
+  [x] -> x
+  [b, a] -> a <> " and " <> b
+  (final : butlast) ->
+    intercalate ", " (reverse butlast) <> ", and " <> final

users/glittershark/xanthous/src/Xanthous/Util/JSON.hs

@@ -0,0 +1,19 @@
+--------------------------------------------------------------------------------
+module Xanthous.Util.JSON
+  ( ReadShowJSON(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Data.Aeson
+--------------------------------------------------------------------------------
+
+newtype ReadShowJSON a = ReadShowJSON a
+  deriving newtype (Read, Show)
+
+instance Show a => ToJSON (ReadShowJSON a) where
+  toJSON = toJSON . show
+
+instance Read a => FromJSON (ReadShowJSON a) where
+  parseJSON = withText "readable"
+    $ maybe (fail "Could not read") pure . readMay

users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs

@@ -0,0 +1,21 @@
+--------------------------------------------------------------------------------
+module Xanthous.Util.Optparse
+  ( readWithGuard
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import qualified Options.Applicative as Opt
+--------------------------------------------------------------------------------
+
+readWithGuard
+  :: Read b
+  => (b -> Bool)
+  -> (b -> String)
+  -> Opt.ReadM b
+readWithGuard predicate errmsg = do
+  res <- Opt.auto
+  unless (predicate res)
+    $ Opt.readerError
+    $ errmsg res
+  pure res

users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE UndecidableInstances #-}
+module Xanthous.Util.QuickCheck
+  ( functionShow
+  , FunctionShow(..)
+  , functionJSON
+  , FunctionJSON(..)
+  , genericArbitrary
+  , GenericArbitrary(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Test.QuickCheck
+import Test.QuickCheck.Function
+import Test.QuickCheck.Instances.ByteString ()
+import Test.QuickCheck.Arbitrary.Generic
+import Data.Aeson
+import GHC.Generics (Rep)
+--------------------------------------------------------------------------------
+
+newtype FunctionShow a = FunctionShow a
+  deriving newtype (Show, Read)
+
+instance (Show a, Read a) => Function (FunctionShow a) where
+  function = functionShow
+
+functionJSON :: (ToJSON a, FromJSON a) => (a -> c) -> a :-> c
+functionJSON = functionMap encode (headEx . decode)
+
+newtype FunctionJSON a = FunctionJSON a
+  deriving newtype (ToJSON, FromJSON)
+
+instance (ToJSON a, FromJSON a) => Function (FunctionJSON a) where
+  function = functionJSON
+
+--------------------------------------------------------------------------------
+
+newtype GenericArbitrary a = GenericArbitrary a
+  deriving newtype Generic
+
+instance (Generic a, GArbitrary rep, Rep a ~ rep)
+  => Arbitrary (GenericArbitrary a) where
+  arbitrary = genericArbitrary