implement yield_bt and some other minor stuff

1 files changed, 77 insertions, 15 deletions

diff --git a/AufgabeFFP6.hs b/AufgabeFFP6.hs
index 2e0a021..b4bb34b 100644
--- a/AufgabeFFP6.hs
+++ b/AufgabeFFP6.hs
@@ -5,39 +5,101 @@ where
 
 import Data.Array
 
-(+) :: Int -> Int -> Int
-(+) = (Prelude.+)
+type F = Array Int Int
+type Op = Int -> Int -> Int
+type G = Array Int (Op)
+type W = Int
 
-(-) :: Int -> Int -> Int
-(-) = (Prelude.-)
-
-(*) :: Int -> Int -> Int
-(*) = (Prelude.*)
+--------------------------------------------------------------------------------
 
 (./.) :: Int -> Int -> Int
 (./.) = div
 
 myfoldl :: [(a -> b -> a)] -> a -> [b] -> a
-myfoldl _ z [] = z
-myfoldl (f:fs) z (x:xs)  = myfoldl fs (f z x) xs
+myfoldl _ f1 [] = f1
+myfoldl (g:gs) f1 (f2:fs)  = myfoldl gs (g f1 f2) fs
 
 myfoldl' :: [(a -> a -> a)] -> [a] -> a
-myfoldl' f (x:xs) = myfoldl f x xs
+myfoldl' g (f:fs) = myfoldl g f fs
 
-eval ::  Array Int Int -> Array Int (Int -> Int -> Int) -> Int
-eval a b = myfoldl' (elems b) (elems a)
+eval :: F -> G -> W
+eval f g = myfoldl' (elems g) (elems f)
 
 --------------------------------------------------------------------------------
 
--- yield :: Array Int Int -> Int -> [Array Int (Int -> Int -> Int)]
--- yield = yield_bt
+yield :: F -> W -> [G]
+yield = yield_bt
 -- yield = yield_gtf
 
--- yield_bt :: Array Int Int -> Int -> [Array Int (Int -> Int -> Int)]
+--------------------------------------------------------------------------------
+
+type Node = ([Int], [Int], W, [Op])
+
+goal_yield_bt :: Node -> Bool
+goal_yield_bt (f, f', w, g)
+  | length g == 0  = False -- no operators
+  | length f' == 0 = eval (listArray (1, length f) f) (listArray (1, length g) g) == w
+  | otherwise      = False
+
+succ_yield_bt :: Node -> [Node]
+succ_yield_bt (_, [], _, _) = []
+succ_yield_bt (f, f', w, g) = [(f_new, f'_new, w, g ++ [g_new]) | g_new <- ops]
+  where
+    f_new  = f ++ [head f']
+    f'_new = tail f'
+    ops    = [(+), (-), (*), (./.)]
+
+data Stack a = EmptyStk
+               | Stk a (Stack a)
+
+push :: a -> Stack a -> Stack a
+push x s = Stk x s
+
+pop :: Stack a -> Stack a
+pop EmptyStk = error "pop from an empty stack"
+pop (Stk _ s) = s
+
+top :: Stack a -> a
+top EmptyStk = error "top from an empty stack"
+top (Stk x _) = x
+
+emptyStack :: Stack a
+emptyStack = EmptyStk
+
+stackEmpty :: Stack a -> Bool
+stackEmpty EmptyStk = True
+stackEmpty _  = False
+
+searchDfs :: (node -> [node]) -> (node -> Bool) -> node -> [node]
+searchDfs succ goal x = search' (push x emptyStack)
+  where
+    search' s
+      | stackEmpty s = []
+      | goal (top s) = top s : search' (pop s)
+      | otherwise =
+        let x = top s
+        in search' (foldr push (pop s) (succ x))
+
+yield_bt :: F -> W -> [G]
+yield_bt f w = map (\(_, _, _, g) -> listArray (1, length g) g) nodes
+  where
+    f_elem1 = head (elems f)
+    f_tail  = tail (elems f)
+    nodes   = searchDfs succ_yield_bt goal_yield_bt ([f_elem1], f_tail, w, [])
+
+--------------------------------------------------------------------------------
+
 -- yield_gtf :: Array Int Int -> Int -> [Array Int (Int -> Int -> Int)]
 
 --------------------------------------------------------------------------------
 
+instance Show (Integer -> Integer -> Integer) where
+  show op = case (3 `op` 3) of
+    6 ->  "plus"
+    0 ->  "minus"
+    9 ->  "times"
+    1 ->  "div"
+    _ ->  "unknown"
 
 instance Show (Int -> Int -> Int) where
   show op = case (3 `op` 3) of