diff options
Diffstat (limited to 'users/aspen/xanthous/src/Xanthous/Util')
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/Util/Comonad.hs | 24 | ||||
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/Util/Graph.hs | 33 | ||||
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/Util/Graphics.hs | 177 | ||||
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/Util/Inflection.hs | 14 | ||||
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/Util/JSON.hs | 19 | ||||
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/Util/Optparse.hs | 21 | ||||
| -rw-r--r-- | users/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs | 32 |
7 files changed, 320 insertions, 0 deletions
diff --git a/users/aspen/xanthous/src/Xanthous/Util/Comonad.hs b/users/aspen/xanthous/src/Xanthous/Util/Comonad.hs new file mode 100644 index 0000000000..9e158cc8e2 --- /dev/null +++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/Graph.hs b/users/aspen/xanthous/src/Xanthous/Util/Graph.hs new file mode 100644 index 0000000000..8e5c04f4bf --- /dev/null +++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/Graphics.hs b/users/aspen/xanthous/src/Xanthous/Util/Graphics.hs new file mode 100644 index 0000000000..0cb009f45a --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util/Graphics.hs @@ -0,0 +1,177 @@ +{-# 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/aspen/xanthous/src/Xanthous/Util/Inflection.hs b/users/aspen/xanthous/src/Xanthous/Util/Inflection.hs new file mode 100644 index 0000000000..724f2339dd --- /dev/null +++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/JSON.hs b/users/aspen/xanthous/src/Xanthous/Util/JSON.hs new file mode 100644 index 0000000000..91d1328e4a --- /dev/null +++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/Optparse.hs b/users/aspen/xanthous/src/Xanthous/Util/Optparse.hs new file mode 100644 index 0000000000..dfa6537235 --- /dev/null +++ b/users/aspen/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/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs b/users/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs new file mode 100644 index 0000000000..aa881b3227 --- /dev/null +++ b/users/aspen/xanthous/src/Xanthous/Util/QuickCheck.hs @@ -0,0 +1,32 @@ +{-# 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 +-------------------------------------------------------------------------------- + +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 |