diff options
author | Griffin Smith <grfn@gws.fyi> | 2021-04-11T21·53-0400 |
---|---|---|
committer | glittershark <grfn@gws.fyi> | 2021-04-12T14·45+0000 |
commit | 6266c5d32f9ff651fcfc3a4cc0c68e89da56ca65 (patch) | |
tree | 5be3967585787c4456e17cb29423770217fdcede /users/glittershark/xanthous/src/Xanthous/Util | |
parent | 968effb5dc1a4617a0dceaffc70e986abe300c6e (diff) |
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>
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Util')
7 files changed, 0 insertions, 331 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs b/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs deleted file mode 100644 index 9e158cc8e2d4..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Comonad.hs +++ /dev/null @@ -1,24 +0,0 @@ --------------------------------------------------------------------------------- -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/glittershark/xanthous/src/Xanthous/Util/Graph.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs deleted file mode 100644 index 8e5c04f4bfa9..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Graph.hs +++ /dev/null @@ -1,33 +0,0 @@ --------------------------------------------------------------------------------- -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/glittershark/xanthous/src/Xanthous/Util/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs deleted file mode 100644 index 6ba63a2d8a3f..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# 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/glittershark/xanthous/src/Xanthous/Util/Inflection.hs b/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs deleted file mode 100644 index 724f2339dd21..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Inflection.hs +++ /dev/null @@ -1,14 +0,0 @@ - -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/glittershark/xanthous/src/Xanthous/Util/JSON.hs b/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs deleted file mode 100644 index 91d1328e4a10..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/JSON.hs +++ /dev/null @@ -1,19 +0,0 @@ --------------------------------------------------------------------------------- -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/glittershark/xanthous/src/Xanthous/Util/Optparse.hs b/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs deleted file mode 100644 index dfa65372351d..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/Optparse.hs +++ /dev/null @@ -1,21 +0,0 @@ --------------------------------------------------------------------------------- -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/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs deleted file mode 100644 index be12bc294513..000000000000 --- a/users/glittershark/xanthous/src/Xanthous/Util/QuickCheck.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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 |