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~
.ghc.environment.*
.DS_Store
result
......@@ -10,20 +10,28 @@ ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
dependencies:
- base >= 4.9 && < 5
- transformers
- free
- data-fix
- mtl
- language-c
library:
source-dirs: src
# tests:
# template-test:
# source-dirs: test/src
# main: Main.hs
# dependencies:
# - template
# - hedgehog
# - hspec
# - hspec-discover
# - hspec-expectations-pretty-diff
# - hspec-hedgehog
tests:
rtree-test:
source-dirs: test/src
main: Main.hs
dependencies:
- rtree
- diagrams
- diagrams-lib
- diagrams-core
- diagrams-contrib
- diagrams-svg
# - template
# - hedgehog
# - hspec
# - hspec-discover
# - hspec-expectations-pretty-diff
# - hspec-hedgehog
......@@ -18,7 +18,32 @@ library
ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
build-depends:
base >=4.9 && <5
, data-fix
, free
, language-c
, mtl
, transformers
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 DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ViewPatterns #-}
{- |
Module: Control.RTree
-}
module Control.RTree where
import Control.Monad
import Control.Applicative (Alternative ((<|>)))
import Data.Functor
import Data.Functor.Identity
import Data.Functor.Classes
import qualified Data.List.NonEmpty as NE
-- | The reduction tree, parameterized by a genrative functor 'f'.
data ReduceT f i
= Done i
| f (ReduceT f i) :<| ReduceT f i
import Data.Coerce (coerce)
import "free" Control.Monad.Free
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,
this means that i@f a <= f b@ iff @a <= b@.
-}
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
instance Show1 RTreeF where
liftShowsPrec = undefined
-- | Extract the input from the reducer.
extract :: ReduceT f i -> i
extract = \case
Done i -> i
_ :<| rhs -> extract rhs
newtype RTree i = RTree {rtreeFree :: Free RTreeF i}
deriving (Show)
deriving (Functor, Applicative, Monad) via (Free RTreeF)
-- | Reduce an input using a monad.
reduce :: (MonadPlus m) => (i -> m ()) -> ReduceT m i -> m i
reduce fn rt = case rt of
Done i -> fn i $> i
lhs :<| rhs -> do
(lhs >>= reduce fn) `mplus` reduce fn rhs
instance MonadFree RTreeF RTree where
wrap x = RTree (Free (fmap rtreeFree x))
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
(<|) :: (Applicative f) => ReduceT f i -> ReduceT f i -> ReduceT f i
f <| b = pure f :<| b
-- | Reduce an input using a monad.
reduce :: (Alternative m) => (i -> m ()) -> RTree i -> m i
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.
given :: (Applicative f) => ReduceT f Bool
given :: RTree Bool
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
@
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
-- | Reducing a list one element at a time.
rList :: (Applicative m) => Reducer m [a]
rList :: [a] -> RTree [a]
rList = \case
[] -> Done []
[] -> pure []
a : as -> rList as <| (a :) <$> rList as
{- | Binary reduction on the list assumming suffixes all contain eachother:
@[] < [c] < [b, c] < [a,b,c]@
-}
rSuffixList :: (Applicative m) => Reducer m [a]
rSuffixList :: [a] -> RTree [a]
rSuffixList as = do
res <- binarySearch (NE.reverse (NE.tails as))
res <- exponentialSearch (NE.tails as)
case res of
[] -> pure []
a : as' -> (a :) <$> rSuffixList as'
......@@ -97,23 +100,41 @@ rSuffixList as = do
{- | Given a progression of inputs that are progressively larger, pick the smallest using
binary search.
-}
binarySearch :: (Applicative m) => NE.NonEmpty i -> ReduceT m i
binarySearch :: NE.NonEmpty i -> RTree i
binarySearch = \case
a NE.:| [] -> Done a
d -> binarySearch f <| binarySearch l
a NE.:| [] -> pure a
d -> binarySearch l <| binarySearch f
where
(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
linearSearch :: (Applicative m) => NE.NonEmpty i -> ReduceT m i
linearSearch = foldr1 (<|) . fmap Done
linearSearch :: NE.NonEmpty i -> RTree i
linearSearch = foldr1 (<|) . fmap pure
-- | 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])
-- | Given
ddmin :: (Applicative m) => [i] -> ReduceT m [i]
ddmin :: [i] -> RTree [i]
ddmin = \case
[] -> pure []
[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.
Finish editing this message first!
Please register or to comment