Permalink
Browse files

* Work + infinite loop? Stuck somewhere in the RTS?

  • Loading branch information...
1 parent fe1f604 commit 0f7abcfea2aa944d492ae4e32ab2a276173bdafa @spockz committed Jan 18, 2012
View
4 resources/static/hjs/Data/Map.hs
@@ -13,4 +13,6 @@ lookup k ((k', v):xs) | k == k' = Just v
insert :: k -> v -> Map k v -> Map k v
insert k v = (:) (k,v)
-assocs = id
+assocs = id
+
+fromList = id
View
18 resources/static/hjs/infinite.hs
@@ -0,0 +1,18 @@
+module Infinite where
+
+import Data.Tree
+
+import Language.UHC.JScript.Assorted (alert)
+import Language.Prolog.NanoProlog.NanoProlog
+import Language.Prolog.NanoProlog.ParserUUTC
+
+import Prolog
+
+main = do alert "start"
+ let p =Node (Fun "ouder" [Var "X",Fun "alex" []]) [Node (Fun "ma" [Var "X",Fun "alex" []]) []]
+ let rules = [Fun "append" [Fun "nil" [],Var "X",Var "Y"] :<-: [],Fun "append" [Fun "cons" [Var "A",Var "X"],Var "Y",Fun "cons" [Var "A",Var "Z"]] :<-: [Fun "append" [Var "X",Var "Y",Var "Z"]],Fun "elem" [Var "X",Fun "cons" [Var "X",Var "Y"]] :<-: [],Fun "elem" [Var "X",Fun "cons" [Var "Z",Var "Y"]] :<-: [Fun "elem" [Var "X",Var "Y"]],Fun "plus" [Fun "zero" [],Var "X",Var "X"] :<-: [],Fun "plus" [Fun "succ" [Var "X"],Var "Y",Fun "succ" [Var "Z"]] :<-: [Fun "plus" [Var "X",Var "Y",Var "Z"]],Fun "ouder" [Var "X",Var "Y"] :<-: [Fun "pa" [Var "X",Var "Y"]],Fun "ouder" [Var "X",Var "Y"] :<-: [Fun "ma" [Var "X",Var "Y"]],Fun "voor" [Var "X",Var "Y"] :<-: [Fun "ouder" [Var "X",Var "Y"]],Fun "voor" [Var "X",Var "Y"] :<-: [Fun "ouder" [Var "X",Var "Z"],Fun "voor" [Var "Z",Var "Y"]],Fun "oma" [Var "X",Var "Z"] :<-: [Fun "ma" [Var "X",Var "Y"],Fun "ouder" [Var "Y",Var "Z"]],Fun "man" [Var "X"] :<-: [Fun "elem" [Var "X",Fun "cons" [Fun "claus" [],Fun "cons" [Fun "alex" [],Fun "cons" [Fun "con" [],Fun "cons" [Fun "fri" [],Fun "empty" []]]]]]],Fun "ma" [Fun "mien" [],Fun "juul" []] :<-: [],Fun "ma" [Fun "juul" [],Fun "bea" []] :<-: [],Fun "ma" [Fun "bea" [],Fun "alex" []] :<-: [],Fun "ma" [Fun "bea" [],Fun "con" []] :<-: [],Fun "ma" [Fun "bea" [],Fun "fri" []] :<-: [],Fun "ma" [Fun "max" [],Fun "ale" []] :<-: [],Fun "ma" [Fun "max" [],Fun "ama" []] :<-: [],Fun "ma" [Fun "max" [],Fun "ari" []] :<-: [],Fun "pa" [Fun "alex" [],Fun "ale" []] :<-: [],Fun "pa" [Fun "alex" [],Fun "ama" []] :<-: [],Fun "pa" [Fun "alex" [],Fun "ari" []] :<-: [],Fun "pa" [Fun "alex" [],Fun "moe" []] :<-: []]
+ --Node ouder(X, alex) [Node ma(X, alex) []]
+ let x = checkProof rules p
+ alert (show x)
+ alert "stop"
+
View
26 resources/static/hjs/jcu.hs
@@ -5,6 +5,7 @@ import Control.Monad (liftM, foldM)
import Data.Array (elems)
import Data.List
+import Data.Map (fromList)
import Data.Maybe (fromJust)
import Data.Tree as T
@@ -123,7 +124,7 @@ buildRuleUl node status =
return (jq, n + 1)
dropje :: Proof -> [Int] -> Proof -> UIThisEventHandler
dropje wp lvl node this _ ui = do
- elemVal <- findSelector this "input[type='text']:first" >>= valString
+ elemVal <- findSelector this "input[type='text']:first" >>= valJSString
jsRuleText <- (getAttr "draggable" ui >>= getAttr "context" >>= getAttr "innerText") :: IO JSString
let ruleText = fromJS jsRuleText :: String
@@ -155,8 +156,7 @@ buildRuleUl node status =
return li
fCheck :: ThisEventHandler
- fCheck this _ = do elemVal <- valString this
- let term = fromJS elemVal :: String
+ fCheck this _ = do term <- valString this
case tryParseTerm term of
(Just t) -> replaceRuleTree $ T.Node t []
_ -> do removeClass this "blueField yellowField redField whiteField greenField"
@@ -165,9 +165,15 @@ buildRuleUl node status =
replaceRuleTree :: Proof -> IO ()
replaceRuleTree p = do
+ alert "start checkproof"
status <- checkProof p
+ alert "end checkproof"
oldUL <- jQuery ruleTreeId
newUL <- buildRuleUl p status
+
+ -- Store new proof in the subst funct
+ registerEvents [("#btnSubst", "click", doSubst p)]
+ -- Draw the new ruleTree
replaceWith oldUL newUL
@@ -195,7 +201,7 @@ addRules obj str obj2 = do
addRuleEvent :: EventHandler
addRuleEvent event = do
- rule <- jQuery "#txtAddRule" >>= valString
+ rule <- jQuery "#txtAddRule" >>= valJSString
let str = JSString.concat (toJS "{\"rule\":\"") $ JSString.concat rule (toJS "\"}")
ajaxQ POST "/rules/stored" str (onSuccess (fromJS rule)) onFail
return True
@@ -214,10 +220,20 @@ createRuleLi rule id = do item <- jQuery $ "<li>" ++ rules_list_item rule ++ "</
checkProof :: Proof -> IO PCheck
checkProof p = do rules <- (jQuery ".rule-list-item" >>= jQueryToArray) :: IO (ECMAArray.JSArray JQuery)
rules' <- (mapM (\ x -> getAttr "innerText" x >>= (return . fromJust . tryParseRule . (fromJS :: JSString -> String))) . elems . jsArrayToArray) rules
+ alert (show p)
+ alert (show rules')
+ alert "start actual checking"
return $ Prolog.checkProof rules' p
-- where f x = do text <- getAttr "innertext"
-
+doSubst :: Proof -> EventHandler
+doSubst p _ = do sub <- jQuery "#txtSubstSub" >>= valString
+ for <- jQuery "#txtSubstFor" >>= valString
+ case tryParseTerm for of
+ Nothing -> return False
+ (Just t) -> do let newP = subst (Env $ fromList [(sub, t)]) p
+ replaceRuleTree newP
+ return True
foreign import jscript "jQuery.noop()"
noop :: IO (JSFunPtr (JSPtr a -> String -> JSPtr b -> IO()))
View
3 resources/static/hjs/makefile
@@ -6,6 +6,9 @@ all: build
build:
${COMPILER} jcu.hs
+infinite:
+ ${COMPILER} infinite.hs
+
testcase: testcases/*.hs
cd testcases && ${COMPILER} alert.hs

0 comments on commit 0f7abcf

Please sign in to comment.