diff options
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 9e158cc8e2..0000000000 --- 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 8e5c04f4bf..0000000000 --- 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 6ba63a2d8a..0000000000 --- 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 724f2339dd..0000000000 --- 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 91d1328e4a..0000000000 --- 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 dfa6537235..0000000000 --- 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 be12bc2945..0000000000 --- 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 |