module Data.Regex.Example.Mono (
Tree'(..), Tree,
Rose'(..), Rose,
pattern Leaf, pattern Branch,
pattern Rose,
aTree1, aTree2, aTree3,
aRose1, aRose2,
pattern Leaf_, pattern Branch_,
rTree1, rTree2, rTree3, rRose1,
eWith1, eWith2,
eWith2Bis, eWith3, eWith4,
grammar1, grammar2, grammar3
) where
import Control.Applicative ((<$>), (<*>))
import Control.Lens hiding (at, (#), children)
import Data.Map ((!))
import qualified Data.Map as M
import Data.Monoid (Sum(..))
import Data.Regex.Generics
import Data.Regex.Rules
import Data.Regex.TH
import GHC.Generics
import Test.QuickCheck
data Tree' f = Leaf' | Branch' { elt :: Int, left :: f, right :: f }
deriving (Generic1, Show)
type Tree = Fix Tree'
instance Arbitrary Tree where
arbitrary = frequency
[ (1, return Leaf)
, (5, Branch <$> arbitrary <*> arbitrary <*> arbitrary) ]
data Rose' f = Rose' { value :: Int, child :: [f] }
deriving (Generic1, Show)
type Rose = Fix Rose'
pattern Leaf = Fix Leaf'
pattern Branch n l r = Fix (Branch' n l r)
pattern Rose v c = Fix (Rose' v c)
instance Show Tree where
show (Fix Leaf') = "Leaf"
show (Fix (Branch' n t1 t2)) = "(Branch " ++ show n ++ " " ++ show t1 ++ " " ++ show t2 ++ ")"
instance Show Rose where
show (Fix (Rose' n c)) = show n ++ show c
aTree1 :: Tree
aTree1 = Branch 2 (Branch 3 (Branch 2 (Branch 4 Leaf Leaf) Leaf) Leaf) Leaf
aTree2 :: Tree
aTree2 = Branch 2 (Branch 2 Leaf Leaf) Leaf
aTree3 :: Tree
aTree3 = Branch 2 Leaf Leaf
aRose1 :: Rose
aRose1 = Rose 2 [Rose 2 [], Rose 2 []]
aRose2 :: Rose
aRose2 = Rose 2 [Rose 2 [], Rose 2 [Rose 3 []]]
rTree1 :: Regex String Tree'
rTree1 = Regex $
iter $ \k ->
capture "x" $
inj (Branch' 2 (square k) (square k))
<||> inj Leaf'
rTree2 :: Integer -> Regex Integer Tree'
rTree2 c = Regex $
iter $ \k ->
capture c $
inj (Branch' 2 (square k) (square k))
<||> inj Leaf'
pattern Branch_ n l r = Inject (Branch' n l r)
pattern Leaf_ = Inject Leaf'
rTree3 :: Integer -> Integer -> Regex Integer Tree'
rTree3 c1 c2 = Regex ( (\k -> c1 <<- Branch_ 2 (k#) (k#) <||> c2 <<- Leaf_)^* )
rRose1 :: Regex String Rose'
rRose1 = Regex $ iter $ \k -> capture "x" $ inj (Rose' 2 [square k])
eWith1 :: Tree -> [Tree]
eWith1 (with rTree2 -> Just e) = e
eWith1 _ = error "What?"
eWith2 :: Tree -> [Tree]
eWith2 (with rTree3 -> Just (_,e)) = e
eWith2 _ = error "What?"
eWith2Bis :: Tree -> [Tree]
eWith2Bis [rx| (\k -> branches <<- Branch_ 2 (k#) (k#) <||> leaves <<- Leaf_)^* |] = leaves
eWith2Bis _ = []
eWith3 :: Tree -> [Tree]
eWith3 [rx| x <<- Leaf_ |] = x
eWith3 _ = error "What?"
eWith4 :: Tree -> [Int]
eWith4 [rx| (\k -> x <<- inj (Branch' __ (k#) (k#)) <||> e <<- Leaf_)^* |] = map (elt . unFix) x
eWith4 _ = error "What?"
unFix :: Fix f -> f (Fix f)
unFix (Fix x) = x
grammar1 :: Grammar String Tree' () String
grammar1 = [ ( Regex $ inj (Branch' 2 ("l" <<- any_) ("r" <<- any_))
, \_ _ children ->
( True
, M.fromList [("l",()),("r",())]
, "(" ++ children ! "l"
++ ")-SPECIAL-("
++ children ! "r" ++ ")" ) )
, ( Regex $ inj (Branch' __ ("l" <<- any_) ("r" <<- any_))
, \(Branch e _ _) _ children ->
( True
, M.fromList [("l",()),("r",())]
, "(" ++ children ! "l"
++ ")-" ++ show e ++ "-("
++ children ! "r" ++ ")" ) )
, ( Regex $ Leaf_, \_ _ _ -> (True, M.empty, "leaf") )
]
grammar2 :: Grammar Integer Tree' () (String, Sum Integer)
grammar2 = [
rule $ \l r ->
inj (Branch' 2 (l <<- any_) (r <<- any_)) ->> do
(lText,lN) <- use (at l . syn)
(rText,rN) <- use (at r . syn)
this.syn._1 .= "(" ++ lText ++ ")-SPECIAL-(" ++ rText ++ ")"
this.syn._2 .= lN + rN
, rule $ \l r ->
inj (Branch' __ (l <<- any_) (r <<- any_)) ->>> \(Branch e _ _) -> do
(lText,lN) <- use (at l . syn)
(rText,rN) <- use (at r . syn)
this.syn._1 .= "(" ++ lText ++ ")-" ++ show e ++ "-(" ++ rText ++ ")"
this.syn._2 .= lN + rN
, rule $ Leaf_ ->> do
this.syn._1 .= "leaf"
this.syn._2 .= Sum 1
]
grammar3 :: Grammar Integer Tree' Char (String, Sum Integer)
grammar3 = [
rule $ \l r ->
inj (Branch' 2 (l <<- any_) (r <<- any_)) ->> do
special <- use (this.inh)
at l . inh .= succ special
at r . inh .= succ special
(lText,lN) <- use (at l . syn)
(rText,rN) <- use (at r . syn)
if lText == "leaf" && rText == "leaf"
then this.syn._1 .= "leaves"
else this.syn._1 .= "(" ++ lText ++ ")-" ++ [special] ++ "-(" ++ rText ++ ")"
this.syn._2 .= lN + rN
, rule $ \l r ->
inj (Branch' __ (l <<- any_) (r <<- any_)) ->>> \(Branch e _ _) -> do
(lText,lN) <- use (at l . syn)
(rText,rN) <- use (at r . syn)
this.syn._1 .= "(" ++ lText ++ ")-" ++ show e ++ "-(" ++ rText ++ ")"
this.syn._2 .= lN + rN
, rule $ Leaf_ ->> do
this.syn._1 .= "leaf"
this.syn._2 .= Sum 1
]