From f48d572675cf213d43ac189ba91f3fe3aa9ae00b Mon Sep 17 00:00:00 2001 From: 3555003 <3555003@46e4088a-c2b5-4d24-90db-838aeec2e325> Date: Thu, 7 Apr 2011 18:10:06 +0000 Subject: [PATCH] Move WX stuff to branch git-svn-id: https://svn.science.uu.nl/repos/edu.3555003.wiskunded/trunk@45 46e4088a-c2b5-4d24-90db-838aeec2e325 --- src/CLI.hs | 39 ------- src/EnableGUI.hs | 19 ---- src/GUI.hs | 265 ----------------------------------------------- src/Prolog.hs | 125 ---------------------- src/accept.png | Bin 781 -> 0 bytes src/delete.png | Bin 715 -> 0 bytes src/help.png | Bin 786 -> 0 bytes 7 files changed, 448 deletions(-) delete mode 100644 src/CLI.hs delete mode 100644 src/EnableGUI.hs delete mode 100644 src/GUI.hs delete mode 100644 src/Prolog.hs delete mode 100755 src/accept.png delete mode 100755 src/delete.png delete mode 100755 src/help.png diff --git a/src/CLI.hs b/src/CLI.hs deleted file mode 100644 index f5badea..0000000 --- a/src/CLI.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Main where - -import Control.Monad (unless) -import Data.Char (isUpper) -import Data.List -import Prolog -import System.IO - -main :: IO () -main = - do hSetBuffering stdin LineBuffering - putStr "File with rules? " - fn <- getLine - s <- readFile fn - let (rules, errors) = startParse pRules s - if null errors - then do mapM_ print rules - loop rules - else do putStrLn "No rules parsed" - mapM_ print errors - main - -loop :: [Rule] -> IO () -loop rules = do putStr "term? " - s <- getLine - unless (s == "stop") $ - do let (goal, errors) = startParse pFun s - if null errors - then printsolutions (solve rules [goal] [] 0) - else do putStrLn "A term was expected:" - mapM_ print errors - loop rules - -printsolutions :: [EnvTrace] -> IO () -printsolutions sols = sequence_ [ printGetLn etr | etr <- sols] - where printGetLn (bs, trace) = do mapM_ (putStr . show) trace - putStr (concatMap (showBdg bs) bs) - getLine - diff --git a/src/EnableGUI.hs b/src/EnableGUI.hs deleted file mode 100644 index 0ed6dd6..0000000 --- a/src/EnableGUI.hs +++ /dev/null @@ -1,19 +0,0 @@ -module EnableGUI(enableGUI) where - -import Data.Int -import Foreign - -type ProcessSerialNumber = Int64 - -foreign import ccall "GetCurrentProcess" getCurrentProcess :: Ptr ProcessSerialNumber -> IO Int16 -foreign import ccall "_CGSDefaultConnection" cgsDefaultConnection :: IO () -foreign import ccall "CPSEnableForegroundOperation" cpsEnableForegroundOperation :: Ptr ProcessSerialNumber -> IO () -foreign import ccall "CPSSignalAppReady" cpsSignalAppReady :: Ptr ProcessSerialNumber -> IO () -foreign import ccall "CPSSetFrontProcess" cpsSetFrontProcess :: Ptr ProcessSerialNumber -> IO () - -enableGUI = alloca $ \psn -> do - getCurrentProcess psn - cgsDefaultConnection - cpsEnableForegroundOperation psn - cpsSignalAppReady psn - cpsSetFrontProcess psn diff --git a/src/GUI.hs b/src/GUI.hs deleted file mode 100644 index dcf20bf..0000000 --- a/src/GUI.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Main where - -import Control.Monad -import Data.Char (isUpper) -import Data.List (intercalate) -import Graphics.UI.WX -import Graphics.UI.WXCore -import Prolog - -main :: IO () -main = start gui - --- TODO: Investigate using a Panel -gui :: IO () -gui = do -- Application frame - f <- frame [text := "Prolog in Haskell"] - sw <- scrolledWindow f [ style := wxVSCROLL - , scrollRate := sz 20 20 - , clientSize := sz 800 500 ] - vlogic <- variable [ value := [] ] - rows <- variable [ value := [] ] - file <- variable [ value := "" ] - rules <- textCtrl f [] - query <- textEntry f [ text := "ouder(X,ama)" ] - output <- textCtrl f [] - rbox <- singleListBox f [] - -- TODO: Get rid of cvas completely. Figure out how the positioning stuff - -- works first. - cvas <- panel sw [ clientSize := sz 800 500 ] - mfile <- menuPane [text := "&File"] - mopen <- menuItem mfile [ text := "&Open\tCtrl+O" - , help := "Open a Prolog file" - , on command := onOpen f rules file ] - msave <- menuItem mfile [ text := "&Save\tCtrl+S" - , help := "Save a Prolog file" - , on command := onSave f rules file ] - msaveas <- menuItem mfile [ text := "&Save As\tCtrl+Shift+S" - , help := "Save As a Prolog file" - , on command := onSaveAs f rules file ] - mquit <- menuQuit mfile [ text := "&Quit" - , help := "Quit the program" - , on command := close f ] - mquery <- menuPane [text := "Query" ] - mrun <- menuItem mquery [ text := "&Run\tCtrl+R" - , help := "Run the query" - , on command := onRun vlogic rules query output ] - addbtn <- button f [ text := "Add" - , on command := onAdd sw rows vlogic - ] - run <- button f [ text := "Run!" - , on command := onRun vlogic rules query output ] - set sw [ layout := column 5 [hfill $ widget cvas] - , clientSize := sz 500 300 ] - set f [ menuBar := [mfile, mquery] - , layout := column 5 [ boxed "Enter rules and queries, press Run and be amazed!" - (overGrid sw rules query output run rbox) - ] - , clientSize := sz 1000 700 ] - onAdd sw rows vlogic -- Adds initial text field - -drawRows :: (Form w1, Valued w, Dimensions w1) => w1 -> w [LogicRow] -> IO () -drawRows sw rows = do - rws <- get rows value - set sw [ layout := grid 5 5 (map mkRowLayout rws) - , clientSize := sz 500 200 ] - -onAdd :: (Form (Window a), Valued w) => Window a -> w [LogicRow] - -> w [EnvTrace] -> IO () -onAdd sw rows vlogic = do - rws <- get rows value - mapM_ disableRow rws -- TODO: We don't need this for all of the rows, only for the first one. - nr <- mkNewRow sw rows vlogic (length rws == 0) - let nrws = nr : rws - set rows [ value := nrws ] - drawRows sw rows - -disableRow :: LogicRow -> IO () -disableRow (LogicRow _ _ (RowControls t o h d)) = do - set t [enabled := False] - set o [enabled := False] - set h [enabled := False] - set d [enabled := False] - -data RowType = TermRow | RuleRow - -data RowControls = RowControls { lgTxtFld :: TextCtrl () - , lgBtnOK :: BitmapButton () - , lgBtnHint :: BitmapButton () - , lgBtnDel :: BitmapButton () } - -data LogicRow = LogicRow { lgTraces :: [EnvTrace] - , lgRowType :: RowType - , lgCtrls :: RowControls } - -lgText :: LogicRow -> IO String -lgText lr = do - val <- get (lgTxtFld $ lgCtrls lr) text - return val - -mkNewRow :: (Form (Window a), Valued w) => Window a -> w [LogicRow] - -> w [EnvTrace] -> Bool -> IO LogicRow -mkNewRow sw rows vlogic isFst = do - lrs <- get rows value - let ist = length lrs `mod` 2 == 0 - nrw <- if ist - then mkRow sw rows vlogic TermRow isFst - else mkRow sw rows vlogic RuleRow isFst - return nrw - -mkRow :: (Form (Window a), Valued w) => Window a -> w [LogicRow] - -> w [EnvTrace] -> RowType -> Bool -> IO LogicRow -mkRow sw rows vlogic rt isFst = do - ctrls <- mkControls sw rows vlogic isFst - return $ LogicRow [] rt ctrls - -mkRowLayout :: LogicRow -> [Layout] -mkRowLayout (LogicRow _ TermRow ctrls) = [ mkControlLayout ctrls - , rule 350 5 ] -mkRowLayout (LogicRow _ RuleRow ctrls) = [ widget $ empty - , mkControlLayout ctrls ] - -mkControlLayout :: RowControls -> Layout -mkControlLayout (RowControls t o h d) = widget $ row 5 [ widget o, widget h - , widget d, widget t ] - -mkControls :: (Form (Window a), Valued w) => Window a -> w [LogicRow] - -> w [EnvTrace] -> Bool -> IO RowControls -mkControls sw rows vlogic isFst = do - fld <- textEntry sw [] - ok <- mkBtn sw "accept.png" (doBtnOK sw rows vlogic fld) - hint <- mkBtn sw "help.png" (doBtnHint sw rows vlogic fld) - del <- mkBtn sw "delete.png" (doBtnDel sw rows) - if isFst - then do set del [visible := False] - set hint [visible := False] - else return () - return $ RowControls fld ok hint del - -mkBtn :: Window a -> FilePath -> IO () -> IO (BitmapButton ()) -mkBtn sw file cmd = bitmapButton sw [ picture := file - , clientSize := sz 16 16 - , on command := cmd ] - -doBtnOK sw rows vlogic fld = do - val <- get fld text - if null val - then set fld [text := "TODO: Color border instead"] - else return () - - -doBtnHint sw rows vlogic fld = undefined -doBtnDel sw rows = popRow sw rows - --- | Remove the top row. Does not remove a row if there is but one left. --- TODO: Really remove the widgets: they slow things down! -popRow :: (Form (Window a), Valued w) => Window a -> w [LogicRow] -> IO () -popRow sw rows = do - rws <- get rows value - case rws of - [] -> return () - [x] -> return () - (x:y:xs) -> do hideCtrls x - enableRow y - set rows [ value := (y:xs) ] - drawRows sw rows - -enableRow :: LogicRow -> IO () -enableRow (LogicRow _ _ (RowControls t o h d)) = do - set t [enabled := True] - set o [enabled := True] - set h [enabled := True] - set d [enabled := True] - -hideCtrls :: LogicRow -> IO () -hideCtrls (LogicRow _ _ (RowControls t o h d)) = do - set t [visible := False] - set o [visible := False] - set h [visible := False] - set d [visible := False] - --- TODO: See if we can use container instead of widget for the inner bunch of --- fields. This might enable actual scrolling. -overGrid :: (Widget w1, Widget w3, Widget w5, Widget w4, Widget w2, Widget w) - => w -> w1 -> w2 -> w3 -> w5 -> w4 -> Layout -overGrid sw rules query output run rbox = row 5 [ widget mgrd - , vfill $ widget rbox ] - where mgrd = grid 5 5 [ [label "Action:", hfill $ widget sw ] - , [label "Rules:", hfill $ widget rules ] - , [label "Query:", hfill $ widget query ] - , [label "Output:", hfill $ widget output ] - , [widget run] - ] - -runDiag :: (t1 -> Bool -> Bool -> t2 -> [(String, [String])] -> String - -> String -> t) -> t1 -> t2 -> t -runDiag diag f hdr = diag f True True hdr - [("Prolog files (*.pro, *.pl)", ["*.pro", "*.pl"])] - "" "" - -onOpen :: (Valued s, Textual w) => Window a -> w -> s String -> IO () -onOpen f rules file = do - diag <- runDiag fileOpenDialog f "Select Prolog file" - case diag of - Nothing -> return () -- TODO: Nice error handling - Just f -> do cnts <- readFile f - set file [value := f] - set rules [ text := cnts ] - -onSave :: (Valued s, Textual w) => Window a -> w -> s String -> IO () -onSave f rules file = do - val <- get file value - if null val - then onSaveAs f rules file - else do rs <- get rules text - writeFile val rs - -onSaveAs :: (Valued s, Textual w) => Window a -> w -> s String -> IO () -onSaveAs f rules file = do - diag <- runDiag fileSaveDialog f "Save Prolog file" - case diag of - Nothing -> return () - Just nm -> do rs <- get rules text - writeFile nm rs - -onRun :: (Textual a, Textual w1, Textual w2, Valued w) => w [EnvTrace] -> w1 - -> w2 -> a -> IO () -onRun vlogic rules query output = do - set output [ text := "Running..." ] - set vlogic [ value := [] ] - rs <- get rules text - let (rules, rerr) = startParse pRules rs - if null rerr - then do qs <- get query text - let (goal, ferr) = startParse pFun qs - if null ferr - then do append output "Done!" - let sol = solve rules [goal] [] 0 - set vlogic [ value := sol ] - showSolutions output sol - else append output $ "Invalid query: " ++ qs - else append output $ "Errors in parsing rules! " ++ show rerr - -append :: Textual a => a -> String -> IO () -append t s = appendText t $ '\n':s - -{- -ouder(X,ama): - - - ma(max, ama):-. pa(alex, ama):-. - --------------- ---------------- - ma(X0, Y0) pa(X0, Y0) --------------------------- -------------------------- -ouder(X0, Y0):-ma(X0, Y0). ouder(X0, Y0):-pa(X0, Y0). --------------------------------------------------------- - ouder(X,ama) --} - -showSolutions :: Textual a => a -> [EnvTrace] -> IO () -showSolutions t es = sequence_ [ showSolution t etr | etr <- es] - where showSolution t (bs, trace) = do mapM_ (append t . show) trace - append t $ concatMap (showBdg bs) bs - diff --git a/src/Prolog.hs b/src/Prolog.hs deleted file mode 100644 index b11d987..0000000 --- a/src/Prolog.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE Rank2Types, FlexibleContexts #-} - -module Prolog where - -import Data.Char (isUpper, isSpace) -import Data.List (intercalate) -import Debug.Trace (trace) -import Text.ParserCombinators.UU -import Text.ParserCombinators.UU.BasicInstances -import Text.ParserCombinators.UU.Utils - -type Ident = String - -data Term = Con Int - | Var Ident - | Fun Ident [Term] - deriving Eq - -data Rule = Term :<-: [Term] -data Trace = Trace { goal :: Term - , unif :: Rule - , env :: Env - , terms :: [Term] } - -type Env = [(Ident, Term)] -type EnvTrace = (Env, [Trace]) - -instance Show Term where - show (Con i) = show i - show (Var i) = i - show (Fun i []) = i - show (Fun i ts) = i ++ "(" ++ showCommas ts ++ ")" - -instance Show Rule where - show (t :<-: []) = show t ++ "." - show (t :<-: ts) = show t ++ ":-" ++ showCommas ts ++ "." - -instance Show Trace where - show (Trace t r e ts) = display "goal : " t ++ - display "unifies with head of : " r ++ - display "new environment : " e ++ - display "new goals : " ts ++ "\n" - where display str val = str ++ show val ++ "\n" - -showCommas :: Show a => [a] -> String -showCommas l = intercalate ", " (map show l) - -lookUp :: Term -> Env -> Term -lookUp (Var x) e = case lookup x e of - Nothing -> Var x - Just res -> lookUp res e -lookUp t _ = t - -class Taggable a where - tag :: Int -> a -> a - -instance Taggable Term where - tag n (Con x) = Con x - tag n (Var x) = Var (x ++ show n) - tag n (Fun x xs) = Fun x (map (tag n) xs) - -instance Taggable Rule where - tag n (c :<-: cs) = tag n c :<-: map (tag n) cs - -unify :: (Term, Term) -> Maybe Env -> Maybe Env -unify _ Nothing = Nothing -unify (t, u) env@(Just e) = trace ("unifying: " ++ show t ++ " " ++ show u ++ "\n") - (uni (lookUp t e) (lookUp u e)) - where uni (Var x) y = Just ((x, y): e) - uni x (Var y) = Just ((y, x): e) - uni (Con x) (Con y) = if x == y then env else Nothing - uni (Fun x xs) (Fun y ys) - | x == y && length xs == length ys = foldr unify env (zip xs ys) - | otherwise = Nothing - uni _ _ = Nothing - -solve :: [Rule] -> [Term] -> Env -> Int -> [EnvTrace] -solve rules [] e _ = [(e, [])] -solve rules (t:ts) e n = - [ (sol, trc:trace) - | tm@(c :<-: cs) <- map (tag n) rules - , Just r <- [unify (t, c) (Just e)] - , let trc = Trace t tm r (cs ++ ts) - , (sol, trace) <- solve rules (cs ++ ts) r (n+1) - ] - --- Solving individual rules: --- We need the right-hand side of the rule, since the left-hand side would bring --- us back to where we were. --- In order to solve the right-hand side, we need the environment with variables --- which map terms like X0 and Y0 to concrete values. --- Actually, we probably don't even want to show X0 and Y0, but concrete values --- instead? --- We need to take the environments into account. - -pRules :: Parser [Rule] -pRules = pList pRule - -pRule :: Parser Rule -pRule = (:<-:) <$> pFun <*> ((pSpaces *> pToken ":-" <* pSpaces *> pTerms) `opt` []) - <* pSpaces <* pDot - -pTerm, pCon, pVar, pFun :: Parser Term -pTerm = pCon <|> pVar <|> pFun -pCon = Con <$> pNatural <* pSpaces -pVar = Var <$> pList1 pUpper <* pSpaces -pFun = Fun <$> (pIdentifier <* pSpaces) <*> (pParens pTerms `opt` []) - -pTerms :: Parser [Term] -pTerms = pListSep pComma (pSpaces *> pTerm <* pSpaces) - -startParse :: Parser a -> String -> (a, [Error LineColPos]) -startParse p inp = parse ((,) <$> p <*> pEnd) $ createStr (LineColPos 0 0 0) inp - -pIdentifier :: Parser String -pIdentifier = (:) <$> pLower <*> pList (pLower <|> pUpper <|> pDigit) <* pSpaces - -showBdg :: Env -> (Ident, Term) -> String -showBdg bs (x, t) | isUpper (head x) && length x == 1 = x ++ " = " ++ showTerm t ++ "\n" - | otherwise = "" - where showTerm :: Term -> String - showTerm (Con n) = show n - showTerm t@(Var _) = showTerm (lookUp t bs) - showTerm (Fun f []) = f - showTerm (Fun f ts) = f ++ "(" ++ intercalate ", " (map showTerm ts) ++ ")" diff --git a/src/accept.png b/src/accept.png deleted file mode 100755 index 89c8129a490b329f3165f32fa0781701aab417ea..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 781 zcmV+o1M>WdP)4-QibtN)VXQDpczE`xXAkUjh%RI>;okxb7K@0kpyQ1k_Y(|Oe7$m(^ zNYX>mI||sUbmn+c3<&FnE=4u#()KBS^SH8e)Qs5i!#lY=$-1gbH6VluzU=m=EP78&5vQ z-?+fFP-G2l&l_QzYealK$;1Rl?FkzXR&Jv@fBPNjCr#AYRyJ7UJQ0v#?)7Ott=>3`#-pV!7>9}>Q1jL)H6h&gkP@3nI=+F3nA~M>u#(n* z8T!#8oEw&-mED4!h4s!N@Jo3S7N&Q6%6l3}nlcd~X@>;uelvPsSkXIgg~e+^T1zSf z3SNj(5%jK~i8@b;CC4}Mrzlg<+1Y8PEBfUp0jJpx4B>@E+cy3`^(Gw`Mf+2&yxZm<$to~Vpgvg&QKNR z_f#1(r6svZt%iF?s+n<8X?B&!h3g9Dbb8_=MX}!;HiQSAh`bp^WMl~Z-44teO7W_Y zV4thSL{h;rJY7!l3%5J4H1!tIzB`Dv+YxO(haWeausGZYkI8^hWj6mzo=L0{%;yxzh{5!Htr?51 zvG|W62MzC8BZ76hRpCyO2zOn<%e)K>NHge!-~)Ap33OdWw6hsLYbCxGNt0%wk_2z7 zfyYvXheSG)5HRK1VB~%mq7Dmurw#bi@hEcOr3&G1ZiF*$M=&9nB#VNf&Q^r$4G5kp zTURh&s)E0%5&hyVD}sp<72~zmAY`Y(9aqO6CXF%=zFHGzO-A&I(pE}v70YQxCPJ{Y z4L+?5-crdLn3ZRPEs!A4ehEY3ZRpL~w9>@aMN+{F4dI@v&>(QDHQum!mG~E^$OS8l z!7?%Uwib*ROP67Hw`ika)gX-(8Ia`-u_IEhxG7U<13kSsMW+$lbb2dUMm5p6pa}cjgA+U$^mJ^AjD?&bdi)8~y+Q002ovPDHLkV1g8IMc@Dc diff --git a/src/help.png b/src/help.png deleted file mode 100755 index 5c870176d4dea68aab9e51166cc3d7a582f326d6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 786 zcmV+t1MU2YP)$XgYMs^AIOw1Qr{*Wn)N-{9ma}x2(<~`9Go1=*>YR!KZvrBS zCd!u}@M0og%Ev@_;Z?Kk>Wwv=%h_57zmt2<_1msz_niYE=YRNPpd%02TK9oK1z z>ooPno}v^sikz_|1XHFx_L%~;ljh7i(jiay5F0x*+(9aXXFCl?AdQj5XlQ65%sEv+ ztfe?|YcjPN*@yYtE~ImQh{l|#A6Z8iu>pf43Rj52CzU_dMQm|S2xR62YjQOn+z8WH zaK=!}ggOZi{4pB7SQ=xC0n|vXP_Bkx_a)FeNd}w8U97BNbSWxa^QW-li9BZ#M1!_xE*?wzt^GcoeoL*JGLSe_+l-JT2#2tz!z&^ z_s5anq&^nBklIMwRvcoP3%qs%%Ea?1c{_*V*Xj&~uLu-2Dp1fUN4<0zMo$EH>*U83 zm_9;Vt%-bE{_J_!If!1y=c+`QVZ>0_BPy z+%^pgnv`f8H)Z%0&Tp8&u*MCIC4igNW5MeWM_DHpDNi)Zxz|9XboOnitwFq$ETN=X zj-tkCJnz**Y4k#6_Ty^B=hWo~L!47r`HoP=x&3T1)JLr2t2+#fH