Skip to content
Snippets Groups Projects
Commit 0b6e390b authored by chrg's avatar chrg
Browse files

Since last time

parent 7fb3f667
No related branches found
No related tags found
No related merge requests found
...@@ -23,3 +23,5 @@ cabal.project.local~ ...@@ -23,3 +23,5 @@ cabal.project.local~
.ghc.environment.* .ghc.environment.*
.DS_Store .DS_Store
result
...@@ -10,17 +10,25 @@ ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror ...@@ -10,17 +10,25 @@ ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
dependencies: dependencies:
- base >= 4.9 && < 5 - base >= 4.9 && < 5
- transformers - transformers
- free
- data-fix
- mtl - mtl
- language-c - language-c
library: library:
source-dirs: src source-dirs: src
# tests: tests:
# template-test: rtree-test:
# source-dirs: test/src source-dirs: test/src
# main: Main.hs main: Main.hs
# dependencies: dependencies:
- rtree
- diagrams
- diagrams-lib
- diagrams-core
- diagrams-contrib
- diagrams-svg
# - template # - template
# - hedgehog # - hedgehog
# - hspec # - hspec
......
...@@ -18,7 +18,32 @@ library ...@@ -18,7 +18,32 @@ library
ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
build-depends: build-depends:
base >=4.9 && <5 base >=4.9 && <5
, data-fix
, free
, language-c , language-c
, mtl , mtl
, transformers , transformers
default-language: Haskell2010 default-language: Haskell2010
test-suite rtree-test
type: exitcode-stdio-1.0
main-is: Main.hs
other-modules:
Paths_rtree
hs-source-dirs:
test/src
ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
build-depends:
base >=4.9 && <5
, data-fix
, diagrams
, diagrams-contrib
, diagrams-core
, diagrams-lib
, diagrams-svg
, free
, language-c
, mtl
, rtree
, transformers
default-language: Haskell2010
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{- | {- |
Module: Control.RTree Module: Control.RTree
-} -}
module Control.RTree where module Control.RTree where
import Control.Monad import Control.Applicative (Alternative ((<|>)))
import Data.Functor import Data.Functor
import Data.Functor.Identity import Data.Functor.Classes
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
-- | The reduction tree, parameterized by a genrative functor 'f'. import Data.Coerce (coerce)
data ReduceT f i import "free" Control.Monad.Free
= Done i
| f (ReduceT f i) :<| ReduceT f i
type RTree i = ReduceT Identity i -- | The reduction tree
data RTreeF f
= f :<| f
| Lab String f f
deriving (Show, Eq, Functor)
{- | The reduction tree is a functor, but only over order-embeddings, instance Show1 RTreeF where
this means that i@f a <= f b@ iff @a <= b@. liftShowsPrec = undefined
-}
instance (Functor f) => Functor (ReduceT f) where
fmap f = \case
Done i -> Done (f i)
mi :<| ri -> fmap (fmap f) mi :<| fmap f ri
instance (Functor f) => Applicative (ReduceT f) where
pure = Done
(<*>) = ap
instance (Functor f) => Monad (ReduceT f) where
ma >>= fa = case ma of
Done i -> fa i
mi :<| ri -> ((>>= fa) <$> mi) :<| (ri >>= fa)
-- | Change the underlying monad using a natural transformation.
liftR :: (Functor f) => (forall a. f a -> g a) -> ReduceT f i -> ReduceT g i
liftR nat = \case
Done i -> Done i
lhs :<| rhs -> nat (liftR nat <$> lhs) :<| liftR nat rhs
-- | Extract the input from the reducer. newtype RTree i = RTree {rtreeFree :: Free RTreeF i}
extract :: ReduceT f i -> i deriving (Show)
extract = \case deriving (Functor, Applicative, Monad) via (Free RTreeF)
Done i -> i
_ :<| rhs -> extract rhs
-- | Reduce an input using a monad. instance MonadFree RTreeF RTree where
reduce :: (MonadPlus m) => (i -> m ()) -> ReduceT m i -> m i wrap x = RTree (Free (fmap rtreeFree x))
reduce fn rt = case rt of
Done i -> fn i $> i
lhs :<| rhs -> do
(lhs >>= reduce fn) `mplus` reduce fn rhs
infixr 3 <| infixr 3 <|
infixl 3 |>
(<|) :: (MonadFree RTreeF r) => r i -> r i -> r i
r1 <| r2 = wrap (r1 :<| r2)
lab :: (MonadFree RTreeF r) => String -> r i -> r i -> r i
lab l r1 r2 = wrap (Lab l r1 r2)
(|>) :: (MonadFree RTreeF r) => r i -> r i -> r i
r1 |> r2 = wrap (r2 :<| r1)
foldR :: (RTreeF a -> a) -> RTree a -> a
foldR fn = coerce $ iter fn
-- | Extract the input from the reducer.
extract :: RTree i -> i
extract = foldR \case
(_ :<| e) -> e
Lab _ _ e -> e
-- Combinators -- | Reduce an input using a monad.
(<|) :: (Applicative f) => ReduceT f i -> ReduceT f i -> ReduceT f i reduce :: (Alternative m) => (i -> m ()) -> RTree i -> m i
f <| b = pure f :<| b reduce fn =
( foldR \case
lhs :<| rhs -> lhs <|> rhs
Lab _ lhs rhs -> lhs <|> rhs
)
. fmap (\i -> fn i $> i)
-- | Split the world on a fact. False it does not happen, and True it does happen. -- | Split the world on a fact. False it does not happen, and True it does happen.
given :: (Applicative f) => ReduceT f Bool given :: RTree Bool
given = pure False <| pure True given = pure False <| pure True
-- | A reducer is something that takes an inputs and returns a reduction tree.
type Reducer m i = i -> ReduceT m i
{- | A reducer should extract itself {- | A reducer should extract itself
@ @
extract . red = id extract . red = id
@ @
-} -}
lawReduceId :: (Eq i) => Reducer m i -> i -> Bool lawReduceId :: (Eq i) => (i -> RTree i) -> i -> Bool
lawReduceId red i = extract (red i) == i lawReduceId red i = extract (red i) == i
-- | Reducing a list one element at a time. -- | Reducing a list one element at a time.
rList :: (Applicative m) => Reducer m [a] rList :: [a] -> RTree [a]
rList = \case rList = \case
[] -> Done [] [] -> pure []
a : as -> rList as <| (a :) <$> rList as a : as -> rList as <| (a :) <$> rList as
{- | Binary reduction on the list assumming suffixes all contain eachother: {- | Binary reduction on the list assumming suffixes all contain eachother:
@[] < [c] < [b, c] < [a,b,c]@ @[] < [c] < [b, c] < [a,b,c]@
-} -}
rSuffixList :: (Applicative m) => Reducer m [a] rSuffixList :: [a] -> RTree [a]
rSuffixList as = do rSuffixList as = do
res <- binarySearch (NE.reverse (NE.tails as)) res <- exponentialSearch (NE.tails as)
case res of case res of
[] -> pure [] [] -> pure []
a : as' -> (a :) <$> rSuffixList as' a : as' -> (a :) <$> rSuffixList as'
...@@ -97,23 +100,41 @@ rSuffixList as = do ...@@ -97,23 +100,41 @@ rSuffixList as = do
{- | Given a progression of inputs that are progressively larger, pick the smallest using {- | Given a progression of inputs that are progressively larger, pick the smallest using
binary search. binary search.
-} -}
binarySearch :: (Applicative m) => NE.NonEmpty i -> ReduceT m i binarySearch :: NE.NonEmpty i -> RTree i
binarySearch = \case binarySearch = \case
a NE.:| [] -> Done a a NE.:| [] -> pure a
d -> binarySearch f <| binarySearch l d -> binarySearch l <| binarySearch f
where where
(NE.fromList -> f, NE.fromList -> l) = NE.splitAt (NE.length d `div` 2) d (NE.fromList -> f, NE.fromList -> l) = NE.splitAt (NE.length d `div` 2) d
{- | Given a progression of inputs that are progressively larger, pick the smallest using
binary search.
-}
exponentialSearch :: NE.NonEmpty i -> RTree i
exponentialSearch = go 1
where
go n = \case
d
| n >= NE.length d -> binarySearch d
| otherwise -> go (n * 2) l <| binarySearch f
where
(NE.fromList -> f, NE.fromList -> l) = NE.splitAt n d
nonEmptyOr :: String -> [a] -> NE.NonEmpty a
nonEmptyOr msg ls = case NE.nonEmpty ls of
Just a -> a
Nothing -> error msg
-- | Given a list of orderd options, the -- | Given a list of orderd options, the
linearSearch :: (Applicative m) => NE.NonEmpty i -> ReduceT m i linearSearch :: NE.NonEmpty i -> RTree i
linearSearch = foldr1 (<|) . fmap Done linearSearch = foldr1 (<|) . fmap pure
-- | Given a list of orderd options, the -- | Given a list of orderd options, the
linearSearch' :: (Applicative m) => [i] -> ReduceT m (Maybe i) linearSearch' :: [i] -> RTree (Maybe i)
linearSearch' is = linearSearch (NE.fromList $ fmap Just is ++ [Nothing]) linearSearch' is = linearSearch (NE.fromList $ fmap Just is ++ [Nothing])
-- | Given -- | Given
ddmin :: (Applicative m) => [i] -> ReduceT m [i] ddmin :: [i] -> RTree [i]
ddmin = \case ddmin = \case
[] -> pure [] [] -> pure []
[a] -> pure [a] [a] -> pure [a]
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# HLINT ignore "Redundant bracket" #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
import Control.RTree
import Control.RTree (exponentialSearch)
import qualified Data.List.NonEmpty as NE
import "diagrams-contrib" Diagrams.TwoD.Layout.Tree
import "diagrams-lib" Diagrams.Prelude hiding (Empty, (<|))
import "diagrams-svg" Diagrams.Backend.SVG ()
import "diagrams-svg" Diagrams.Backend.SVG.CmdLine
type Var = String
data Exp
= Num Int
| Add Exp Exp
| Let Var Exp Exp
| Var Var
replace :: Var -> Exp -> Exp -> Exp
replace v e = \case
Num n -> Num n
Add e1 e2 -> Add (replace v e e1) (replace v e e2)
Let v1 e1 e2
| v1 /= v -> Let v1 (replace v e e1) (replace v e e2)
| otherwise -> Let v1 e1 e2
Var v'
| v == v' -> e
| otherwise -> Var v'
instance Show Exp where
showsPrec n = \case
Num n' -> shows n'
Add e1 e2 ->
showParen (n > 2) (showsPrec 2 e1 . showString " + " . showsPrec 3 e2)
Let v e1 e2 ->
showParen (n > 0)
$ showString v
. showString ":="
. showsPrec 1 e1
. showString "; "
. shows e2
Var v -> showString v
expR :: Exp -> RTree Exp
expR = \case
Num n ->
pure (Num 0) <| pure (Num n)
Add e1 e2 ->
expR e1 <| expR e2 <| (Add <$> expR e1 <*> expR e2)
Let v e1 e2 ->
expR (replace v e1 e2) <| Let v <$> expR e1 <*> expR e2
Var v -> pure (Var v)
genD :: (Show e) => RTree e -> BTree (QDiagram SVG V2 Double Any)
genD =
foldR
( \(lhs :<| rhs) ->
BNode
( triangle 0.2
# rotate (90 @@ deg)
<> circle 0.2
# fc white
# lc white
)
lhs
rhs
)
. fmap
( \i ->
BNode
( text (show i)
# fontSizeL 0.3
<> circle 0.3
# fc white
# lc white
)
Empty
Empty
)
-- ( text n
-- # fontSizeL (0.5 :: (Double))
-- <> circle 0.3
-- # fc white
-- )
main :: IO ()
main = do
let Just t' =
uniqueXLayout
1
1.2
-- (genD (binarySearch (1 NE.:| [2, 3, 4, 5, 7, 6, 8 :: Int])))
-- (genD (binarySearch (1 NE.:| [2, 3, 4, 5, 7, 6, 8 :: Int])))
(genD (rSuffixList [1, 2, 3, 4, 5 :: Int]))
-- (genD (expR (Let "x" (Num 10) (Add (Num 2) (Add (Var "x") (Num 3))))))
defaultMain
$ renderTree id (~~) (forceLayoutTree t')
# centerXY
# pad 1.1
cabal test --test-options='-o test.svg -w 600 -h 400' --test-show-details=streaming
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment