Skip to content
Snippets Groups Projects
Commit 080f397b authored by Hendrik Rassmann's avatar Hendrik Rassmann
Browse files

dup pop on ints

parent 3c41aac5
No related branches found
No related tags found
No related merge requests found
module Main where
import TC0
--import TC0
import TC
import PSLex
import BaseTypes (BaseType (IntType))
import ExpTerm
example_ps = "1 dup %# Int Int\n add %# Int\n pop %# 1\n"
example_tokens = scanPS example_ps
example_exprs = ps2exp <$> example_tokens
example_step = step newEnv (example_exprs !! 0)
getS (Annotation s) = s
step_through :: Env -> [Expr BaseType] -> IO ()
step_through env [] = putStrLn "done:" >> putStrLn (show env)
step_through env (t:ts) = do
putStrLn "env:"
putStrLn $ show env
putStrLn $ "term:"
putStrLn $ show (t:ts)
step_through (step env t) (ts)
main = do
putStrLn "new TC on da way!"
putStrLn "example Program:"
putStrLn $ show example_ps
putStrLn "Tokenized:"
putStrLn $ show example_tokens
putStrLn "List of Expr ():"
putStrLn $ show $ example_exprs
putStrLn "######################################"
step_through newEnv example_exprs
{-
old_main = do
tokens <- example_Tokens
let pref = find_prefix tokens
putStrLn $ "works for: " ++ (show $ pref)
putStrLn $ "remaining: " ++ (show $ length tokens - pref)
putStrLn $ "breaks for: " ++ (show $ tokens !! pref)
-}
......@@ -90,17 +90,17 @@ example_File :: IO String
example_File = do
readFile "output.ps"
example_Tokens = (parseBlocks.alexScanTokens) <$> example_File
example_Tokens = (parseBlocks.scanPS) <$> example_File
example_State = do
s <- readFile "output.ps"
let program = init_gs $ token2Type <$> parseBlocks (alexScanTokens s)
let program = init_gs $ token2Type <$> parseBlocks (scanPS s)
pure program
diagram = do
s <- readFile "output.ps"
let program = token2Type <$> parseBlocks (alexScanTokens s)
let program = token2Type <$> parseBlocks (scanPS s)
pure program
mainloop :: (Maybe (String, (Words,[ExpType],[ExpType]) )) -> IO ()
......@@ -118,12 +118,12 @@ mainloop input =
main = do
s <- readFile "output.ps"
let program = token2Type <$> parseBlocks (alexScanTokens s)
let program = token2Type <$> parseBlocks (scanPS s)
mainloop (Just ("Starting Eval",(buildins,[],program)))
--l <- getLine
--let n = (read l) :: Int
--putStrLn $ show $ typecheck $ token2Type <$> (take 15 $ alexScanTokens s)
--putStrLn $ show $ typecheck $ token2Type <$> (take 15 $ scanPS s)
-- utils
......
......@@ -8,12 +8,12 @@ Library StaX
hs-source-dirs: lib
build-tool-depends: alex:alex >= 3.2.1 && < 3.3, happy:happy >= 1.19.5 && < 1.20
build-depends: array, base
exposed-modules: PSLex, AnnoLex, AnnoParse, ExpTerm, BaseTypes
exposed-modules: PSLex, AnnoLex, AnnoParse, ExpTerm, BaseTypes, TC
default-language: Haskell2010
executable tc_gen0.hs
executable Main.hs
main-is: Main.hs
other-modules: TC0, PSLex, AnnoLex, AnnoParse, ExpTerm, BaseTypes
other-modules: TC0, TC, PSLex, AnnoLex, AnnoParse, ExpTerm, BaseTypes
build-depends: base >=4.17.2.1,
QuickCheck ^>= 2.15,
process >= 1.5,
......@@ -25,7 +25,7 @@ executable tc_gen0.hs
Test-Suite Test
type: exitcode-stdio-1.0
main-is: Test.hs
other-modules: AnnoLex, PSLex, TC0
other-modules: AnnoLex, PSLex, TC0, TC
build-depends: base >= 4.3 && <5,
QuickCheck ^>=2.15,
hspec >=2.10,
......
......@@ -6,6 +6,7 @@ module AnnoLex(AnnoToken(..), scanAnnos) where
tokens :-
$white+ ;
"%#" ;
"->" {const Arrow_Token}
"Int" | "I" {const Int_Token}
"Float" | "F" {const Float_Token}
......
......@@ -52,6 +52,7 @@ Exp : Exp '->' Exp { Seq [Neg $1, $3] }
| Exp '+' Exp { Alt [$1, $3] }
PI : {- empty -} { [] }
| one { [] }
| PI L { $2 : $1 }
L : int { Node IntType}
......
module ExpTerm where
import Debug.Trace
type Probability = Double
data Expr a = Node a
| Tag (Expr a) -- == 1 to be interpreted as a comment
| Seq [Expr a]
| Alt [Expr a]
| Thing
-- | Alt ([(Expr a, Probability)])
-- | Star (Expr a) -- == [0.5 0 + .25*a + .125*aa + ...]
| Code (Expr a)
| Neg (Expr a)
| Zero -- not needed once Alt is added
| Var Int -- This will later need function injection (or some form of custom expressions), to facilitate _Nat-Manipulation
| Zero String -- String contains error message -- maybe not needed once Alt is added
deriving (Show, Eq)
--instance (Eq a) => Eq (Expr a) where
instance Functor Expr where
fmap f (Node a) = Node $ f a
fmap f (Seq xs) = Seq $ fmap (fmap f) xs
......@@ -21,7 +26,56 @@ instance Functor Expr where
fmap f (Code a) = Code $ fmap f a
fmap f (Neg a) = Neg $ fmap f a
main = putStrLn $ exprTree $ Seq [Neg (Node 3), Alt [Seq [(Node 7),Zero] , Code (Node 1)]]
instance (Show a) => Semigroup (Expr a) where
(Seq []) <> r = r -- Identity
l <> (Seq []) = l -- Identity
(Seq l) <> (Seq r) = Seq (l <> r)
(Seq l) <> r = Seq (l ++ [r])
(Node l) <> (Seq r)= Seq ((Node l):r)
(Node l) <> (Node r) = Seq[(Node l),(Node r)]
l <> r = error $ "(<>) Failed for " <> (show l) <> " <> " <> (show r)
-- main = putStrLn $ exprTree $ Seq [Neg (Node 3), Alt [Seq [(Node 7),Zero] , Code (Node 1)]]
top :: (Expr a) -> (Expr a)
top (Node a) = Node a
top (Thing) = Thing
top (Neg x) = Neg (top x)
top (Seq []) = Zero "top of stack empty"
top (Seq xs) = top (last xs)
pop :: (Show a) => (Expr a) -> (Expr a)
pop (Node a) = Seq []
pop (Seq []) = Zero "popping from empty Stack"
pop (Seq xs) = case (last xs) of
(Node a) -> Seq (init xs)
Thing -> Seq (init xs)
(Neg a) -> error "this only works if pop knows that to pop, not necc for Demo"
pop x = trace ("unknown: " <> (show x)) (error "implement a match for this!")
--in therory toList not needed
toList :: (Expr a) -> [Expr a]
toList (Seq xs) = xs
toList x = [x]
--assume-NNFs :(
groupSeq :: (Expr a) -> (Expr a)
groupSeq (Seq xs) = Seq $ concat $ toList <$> groupSeq <$> xs where
groupSeq (Node x) = Seq [Node x]
groupSeq (Alt xs) = Alt $ groupSeq <$> xs
groupSeq (Neg (Node x)) = Seq [Neg (Node x)]
(!!!) :: (Show a) => (Expr a) -> Int -> Expr a
(Node x) !!! 0 = (Node x)
(Node _) !!! _ = undefined
Thing !!! 0 = Thing
Thing !!! _ = undefined
(Seq xs) !!! i = xs !! i
x !!! i = trace ("!!! of: " <> (show x)) error "welp"
-- Alt-Gr + s
ſ :: (Eq a) => (Expr a) -> (Expr a) -> Bool
(ſ) l r = (groupSeq l) == (groupSeq r)
type Dot = String
type ID = Int
......@@ -42,7 +96,7 @@ exprTree x = "digraph G {\n" <> (fst $ f x ("0 [style = invis];\n",(0,1))) <> "}
(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"
f (Zero msg) (d,(pID,nID)) = (d <> n (:" <> msg) nID pID "shape=doublecircle"
,nID + 1 )
in_negation_normal_form :: (Expr a) -> Bool
......@@ -53,5 +107,3 @@ 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
{
module PSLex (Token(..), alexScanTokens) where
module PSLex (Token(..), scanPS) where
{-
How to use:
1. It'S just tokenizing, not parsing!
......@@ -63,12 +63,13 @@ instance Show Token where
show CloseArray= " ] "
show (PSInt i) = " " ++ (show i) ++ " "
show (PSFloat f) = " " ++ (show f) ++ " "
show (Comment s) = " " ++ s ++ "\n"
show (Comment s) = " " ++ s ++ "\n" -- this makes pretty printing hard, but is necc to make lex <-> show
show (PSString s) = " (" ++ s ++ ") "
show (Name s) = " " ++ s ++ " "
show (Annotation s) = s ++ "\n"
show (Unknown u) = " " ++ u ++ " "
scanPS = alexScanTokens
--main = do
-- s <- getContents
-- print (alexScanTokens s)
......
module TC where
import PSLex
import ExpTerm
import AnnoLex
import AnnoParse (annoParse)
import BaseTypes
main = putStrLn "check some types!"
type Term = Expr BaseType
ps2exp :: Token -> Term
ps2exp (PSInt _ ) = Node IntType
ps2exp (Unknown "add") = Seq [Neg (Node (IntType)), Neg (Node (IntType)), Node (IntType) ]
ps2exp (Unknown "pop") = Neg Thing
ps2exp (Unknown "dup") = Seq [Neg Thing, Var 0, Var 0]
ps2exp (Annotation s) = Tag $ annoParse $ scanAnnos s
data Env = Env { stack :: Term
, popped :: Term} deriving (Show)
--longTerm: popped can't really be a list.
--assume NNF
step :: Env -> Term -> Env
step env (Node a) = env {stack = stack env <> (Node a)}
step env (Tag x) = if ſ x (stack env) then env else error $ "not matching annotation:\n Anno: " <> (show x) <> "\n stack: " <> (show (stack env))
step env (Seq []) = env
step env (Seq (x:xs)) = step (step env x) (Seq xs)
step env (Neg (Node x)) = env {stack = (pop (stack env)), popped = (popped env <> (Node x))} -- NO TEST, FIX
step env (Neg Thing) = env {stack = (pop (stack env)),popped = (popped env <> (top (stack env)))} -- << HERE poped thing
step env (Var i) = env {stack = (stack env) <> (popped env !!! i)} -- !! scarry
newEnv :: Env
newEnv = Env (Seq []) (Seq [])
modue
......@@ -13,6 +13,7 @@ import System.Exit (exitFailure)
import PSLex
import AnnoLex
import TC0
--import TC
ps_program :: Gen [String]
ps_program = listOf $ elements ["1 ","add "]
......@@ -30,7 +31,7 @@ gs :: [String] -> IO String
gs program = readProcess "gs" ["-q", "-dNODISPLAY"] $ (concat program) ++ "\n"
prop_show_inv_scan :: [Token] -> Bool
prop_show_inv_scan tokens = tokens == (alexScanTokens (concat (show <$> tokens)))
prop_show_inv_scan tokens = tokens == (scanPS (concat (show <$> tokens)))
check_prefix_height :: [Token] -> Int -> IO Bool
check_prefix_height tokens n = do
......@@ -58,15 +59,15 @@ prop_stackShorterProgram = forAll ps_program $ \tokens -> monadicIO $ do
Just n -> n == (length tokens)
main :: IO ()
main = hspec $ do
describe "alexScanTokens" $ do
describe "scanPS" $ do
it "scanns the example file" $ do
s <- readFile "output.ps"
let ts = parseBlocks $ alexScanTokens s
let ts = parseBlocks $ scanPS s
(length ts) > 0 `shouldBe` True
describe "find_prefix" $ do
it "works for 10" $ do
s <- readFile "output.ps"
let ts = parseBlocks $ alexScanTokens s
let ts = parseBlocks $ scanPS s
(find_prefix ts) > 10 `shouldBe` True
-- it "returns the first element of an *arbitrary* list" $
-- property $ \x xs -> head (x:xs) == (x :: Int)
......@@ -76,7 +77,7 @@ main = hspec $ do
{-
main = do
s <- readFile "output.ps"
let ts = parseBlocks $ alexScanTokens s
let ts = parseBlocks $ scanPS s
-- result <- quickCheckResult prop_stackShorterProgram
-- unless (isSuccess result) exitFailure
-- result2 <- quickCheckResult $ prop_show_inv_scan ts
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment