b4 gesrpäch

gen0_virtuous_cycle/app/Main.hs

@@ -6,7 +6,7 @@ import PSLex
 import BaseTypes (BaseType (IntType, BoolType))
 import ExpTerm
 
-example_ps = "{} {exec} dup exec" -- "true false and not" -- 1 2 pop dup "-- %# Int Int\n add %# Int\n pop %# 1\n"
+example_ps = "3 4 {add} {exec} dup exec" -- "true false and not" -- 1 2 pop dup "-- %# Int Int\n add %# Int\n pop %# 1\n"
 example_tokens = scanPS example_ps
 example_exprs = pss2exps example_tokens
 
@@ -31,4 +31,4 @@ main = do
  putStrLn "######################################"
  putStrLn "now in FNNF"
  putStrLn $ show $ expr2fnnf <$> example_exprs
- step_through_FNNF [newENV] $ expr2fnnf <$> example_exprs
+ step_through_FNNF [newENV] $ (<> (TAU FORGET)) <$> expr2fnnf <$> example_exprs

gen0_virtuous_cycle/lib/ExpTerm.hs

@@ -18,6 +18,8 @@ data NOPI a = PUSH a
             | EX (NOPI a) -- UNQUOTE (NOPI a) -- unquote, exec, bang
             | ZERO String
             | VAR Int
+            | STAR (FNNF a)
+            | FORGET
             | TAG (FNNF a) deriving (Functor, Show, Eq) -- !!! 2 could be shifted by Tags!!! ensure this doesn't happen
 
 exec (CODE c) = c
@@ -45,10 +47,13 @@ instance Semiring (FNNF a) where
   (<+>) l r = TAU $ SIGMA $ [l,r] -- if i add Eq constraint, we can normalize here if l == r, or l and r have a common prefix
   zero = TAU $ ZERO "semiring zero"
 
+instance (Eq a) => Ord (FNNF a) where
+
 class (Functor s) => Stack s where
   (!!!) :: (s a) -> Int -> (s a)
   (!<!) :: (s a) -> Int -> (s a)
   split :: (s a) -> (s a, s  a)
+  neutral  :: (s a) -> Bool
   top ::  (s a) -> (s a)
   top = fst.split
   pop :: (s a) -> (s a)
@@ -188,6 +193,7 @@ groupSeq (Neg (Node x)) = Seq [Neg (Node x)]
 
 instance Stack Expr where
   _ !<! _ = error "not needed on this lvl"
+  neutral _ = error "not needed on this lvl"
   (Node x) !!! 0 = Node x
   (Node _) !!! _ = undefined
   (Seq xs) !!! i = (xs !! i) !!! 0
@@ -206,10 +212,17 @@ instance Stack Expr where
   split x = (top x, pop x)
 
 instance Stack FNNF where
+  neutral (PI []) = True
+  neutral (TAU (TAG _)) = True
+  neutral (TAU FORGET) = True
+  neutral (TAU (SIGMA os)) = or $ neutral <$> os
+  neutral (TAU (STAR _)) = error $ "think about this in the future"
+  neutral _ = False
   t@(TAU (PUSH x)) !!! 0 = t
-  (PI (x:xs)) !!! 0 = TAU x
+  (PI (x:xs)) !!! 0 = (TAU x) !!! 0
   (PI (x:xs)) !!! n
    | n < 0 = error "no negative index possible"
+   | neutral (TAU x) = (PI xs) !!! (n)
    | otherwise = (PI xs) !!! (n - 1)
   (PI []) !!! _ = TAU $ ZERO "stack empty, no nth element" -- introduce negative types, soon
   t@(TAU (PUSH x)) !<! 0 = t
@@ -218,7 +231,9 @@ instance Stack FNNF where
   p@(PI xs) !<! i = (pop p) !<! (i-1)
   split t@(TAU x) = (t, PI [])
   split (PI []) = error "No top elem" -- could work with negative types
-  split (PI (xs)) =  (TAU (last xs), PI (init xs))
+  split (PI (xs))
+    | neutral (TAU (last xs)) = error $ "think about htis later"
+    | otherwise =  (TAU (last xs), PI (init xs))
 
 
 

gen0_virtuous_cycle/lib/TC.hs

@@ -68,6 +68,7 @@ stepPI env (PI xs) = foldM (stepNOPI) env xs
 
 stepNOPI :: ENV -> (NOPI BaseType) -> [ENV]
 stepNOPI ENV{s = (TAU (ZERO _)) } _ = []
+stepNOPI env FORGET = pure env{ p = PI []}
 stepNOPI env (PUSH a) = pure $ env {s = s env <> (TAU (PUSH a))}
 --stepNOPI env (PLOP) = pure $ trace ("PLOPPING result: " ++ (show result)) result where result = env {s = pop (s env), p = (p env) <> (top (s env))}
 stepNOPI env (PLOP) = pure $ env {s = pop (s env), p = (p env) <> (top (s env))}
@@ -81,7 +82,7 @@ stepNOPI env (SIGMA (x:xs)) = (stepPI env x) ++ (stepPI env (TAU $ SIGMA xs))
 stepNOPI env (CODE c) = pure $ env {s = (s env) <> (TAU (CODE c))}
 -- you could exec other TAUs aswell, but prob. won't happen
 stepNOPI env (EX (CODE c)) = stepPI env c
-stepNOPI env (EX (VAR i))  = trace ("Executing Var " ++ (show i) ++ ": env:\n>>>" ++ (show env)) $ case (p env !<! i) of
+stepNOPI env (EX (VAR i))  = case (p env !<! i) of
                             TAU (CODE c) -> stepPI env c
                             TAU x        -> stepNOPI env x
                             x            -> error $ "not implemented execution for " ++ (show x)