maybe killing old code

gen0_virtuous_cycle/app/nano.19516.save

+
+
+dasfafds
+asdwq c

gen0_virtuous_cycle/lib/ExpTerm.hs

 module ExpTerm where
 
+
 type Probability = Double
 
 data Expr a = Node a
@@ -20,4 +21,37 @@ instance Functor Expr where
   fmap f (Code a) = Code $ fmap f a
   fmap f (Neg a)  = Neg $ fmap f a
 
-main = putStrLn "main ExpTerm"
+main = putStrLn $ exprTree $ Seq [Neg (Node 3), Alt [Seq [(Node 7),Zero] , Code (Node 1)]]
+
+type Dot = String
+type ID = Int
+exprTree :: (Show a) => Expr a -> String
+exprTree x = "digraph G {\n" <> (fst $ f x ("0 [style = invis];\n",(0,1))) <> "}" where
+             n :: String -> ID -> ID -> String -> Dot
+             n s nID pID style = show nID <> " [label= \"" <> s <> "\", " <> style <> "] " <> (show pID) <> "->" <> (show nID) <> ";\n"
+             f :: (Show a) => Expr a -> (Dot, (ID, ID)) -> (Dot,ID)
+             f (Node a) (d,(pID,nID)) = (d <> n (show a) nID pID "shape=note"
+                                        ,nID + 1 )
+             f (Seq qs) (d,(pID,nID)) = let (dot,nID') = (foldl (\(d,n) q -> (f q (d,(nID,n)))))  ("",(nID+1)) qs in --prob 1: losing old dot, prob 2: double quoting
+                                        (d <> n "*" nID pID "shape=triangle" <> dot
+                                        , nID')
+             f (Alt qs) (d,(pID,nID)) = let (dot,nID') = (foldl (\(d,n) q -> (f q (d,(nID,n)))))  ("",(nID+1)) qs in --prob 1: losing old dot, prob 2: double quoting
+                                        (d <> n "+" nID pID "shape=diamond" <> dot
+                                        , nID')
+             f (Code x) (d,(pID,nID)) = let (dot,nID') = f x ("",(nID,nID+1)) in
+                                        (d <> n "{}" nID pID "shape=hexagon" <> dot, nID')
+             f (Neg x) (d,(pID,nID))  = let (dot,nID') = f x ("",(nID,nID+1)) in
+                                        (d <> n "~" nID pID "shape=insulator" <> dot, nID')
+             f (Zero) (d,(pID,nID))   = (d <> n ("Ø") nID pID "shape=doublecircle"
+                                        ,nID + 1 )
+
+in_negation_normal_form :: (Expr a)   -> Bool
+in_negation_normal_form (Node _)       = True
+in_negation_normal_form (Neg (Node _)) = True
+in_negation_normal_form (Neg _)        = False
+in_negation_normal_form (Code x)       = in_negation_normal_form x
+in_negation_normal_form (Alt x)        = all in_negation_normal_form x
+in_negation_normal_form (Seq x)        = all in_negation_normal_form x
+
+
+-- $> main