refactor(users/glittershark): Rename to grfn r/2485

Rename my //users directory and all places that refer to glittershark to
grfn, including nix references and documentation.

This may require some extra attention inside of gerrit's database after
it lands to allow me to actually push things.

Change-Id: I4728b7ec2c60024392c1c1fa6e0d4a59b3e266fa
Reviewed-on: https://cl.tvl.fyi/c/depot/+/2933
Tested-by: BuildkiteCI
Reviewed-by: tazjin <mail@tazj.in>
Reviewed-by: lukegb <lukegb@tvl.fyi>
Reviewed-by: glittershark <grfn@gws.fyi>

7 files changed, 331 insertions, 0 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/Util/Comonad.hs b/users/grfn/xanthous/src/Xanthous/Util/Comonad.hs
new file mode 100644
index 0000000000..9e158cc8e2
--- /dev/null
+++ b/users/grfn/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 #-}
diff --git a/users/grfn/xanthous/src/Xanthous/Util/Graph.hs b/users/grfn/xanthous/src/Xanthous/Util/Graph.hs
new file mode 100644
index 0000000000..8e5c04f4bf
--- /dev/null
+++ b/users/grfn/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₂)
diff --git a/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs b/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs
new file mode 100644
index 0000000000..6ba63a2d8a
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Util/Graphics.hs
@@ -0,0 +1,178 @@
+{-# 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)
+       => V2 i -- ^ center
+       -> i    -- ^ radius
+       -> [V2 i]
+circle (V2 x₀ y₀) radius
+  -- Four initial points, plus the generated points
+  = V2 x₀ (y₀ + radius)
+  : V2 x₀ (y₀ - radius)
+  : V2 (x₀ + radius) y₀
+  : V2 (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 (V2 x y)
+        = [ V2 (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 (V2 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 (V2 i)
+  }
+makeLenses ''FillState
+
+runFillState :: NonEmpty (V2 i) -> State (FillState i) a -> [V2 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)
+             => V2 i -- ^ center
+             -> i    -- ^ radius
+             -> [V2 i]
+filledCircle center radius =
+  case NE.nonEmpty (circle center 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 = V2 x y
+              next = V2 x $ succ y
+          whenM (use inCircle) $ result %= NE.cons pt
+
+          when (pt `elem` circumference && next `notElem` circumference)
+            $ inCircle %= not
+
+      where
+        (V2 minX minY, V2 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) => V2 i -> V2 i -> [V2 i]
+line pa@(V2 xa ya) pb@(V2 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 view _yx else id
+    [V2 x₁ y₁, V2 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 ((V2 xTemp yTemp), (xTemp + 1, newY, newError))
+      where
+        tempError        = err + δy
+        (newY, newError) = if (2 * tempError) >= δx
+                           then (yTemp + ystep, tempError - δx)
+                           else (yTemp, tempError)
+{-# SPECIALIZE line :: V2 Int -> V2 Int -> [V2 Int] #-}
+{-# SPECIALIZE line :: V2 Word -> V2 Word -> [V2 Word] #-}
+
+straightLine :: (Num i, Ord i) => V2 i -> V2 i -> [V2 i]
+straightLine pa@(V2 xa _) pb@(V2 _ yb) = line pa midpoint ++ line midpoint pb
+  where midpoint = V2 xa yb
+
+
+delaunay
+  :: (Ord n, Fractional n)
+  => NonEmpty (V2 n, p)
+  -> [((V2 n, p), (V2 n, p))]
+delaunay
+  = map (over both fromPoint)
+  . Geometry.edgesAsPoints
+  . 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) => [V2 i] -> String
+renderBooleanGraphics [] = ""
+renderBooleanGraphics (pt : pts') = intercalate "\n" rows
+  where
+    rows = row <$> [minX..maxX]
+    row x = [minY..maxY] <&> \y -> if V2 x y `member` ptSet then 'X' else ' '
+    (V2 minX minY, V2 maxX maxY) = minmaxes pts
+    pts = pt :| pts'
+    ptSet :: Set (V2 i)
+    ptSet = setFromList $ toList pts
+
+showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [V2 i] -> IO ()
+showBooleanGraphics = putStrLn . pack . renderBooleanGraphics
+
+minmaxes :: forall i. (Ord i) => NonEmpty (V2 i) -> (V2 i, V2 i)
+minmaxes xs =
+  ( V2 (minimum1Of (traverse1 . _x) xs)
+       (minimum1Of (traverse1 . _y) xs)
+  , V2 (maximum1Of (traverse1 . _x) xs)
+       (maximum1Of (traverse1 . _y) xs)
+  )
diff --git a/users/grfn/xanthous/src/Xanthous/Util/Inflection.hs b/users/grfn/xanthous/src/Xanthous/Util/Inflection.hs
new file mode 100644
index 0000000000..724f2339dd
--- /dev/null
+++ b/users/grfn/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
diff --git a/users/grfn/xanthous/src/Xanthous/Util/JSON.hs b/users/grfn/xanthous/src/Xanthous/Util/JSON.hs
new file mode 100644
index 0000000000..91d1328e4a
--- /dev/null
+++ b/users/grfn/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
diff --git a/users/grfn/xanthous/src/Xanthous/Util/Optparse.hs b/users/grfn/xanthous/src/Xanthous/Util/Optparse.hs
new file mode 100644
index 0000000000..dfa6537235
--- /dev/null
+++ b/users/grfn/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
diff --git a/users/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/grfn/xanthous/src/Xanthous/Util/QuickCheck.hs
new file mode 100644
index 0000000000..be12bc2945
--- /dev/null
+++ b/users/grfn/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