Permalink
Browse files

* Minor cleanup

* Reset functionality
  • Loading branch information...
1 parent 0f7abcf commit dcb5877661e3ab45841eb9f1d770306b7a19479a @spockz committed Jan 18, 2012
Showing with 24 additions and 14 deletions.
  1. +1 −1 resources/static/hjs/infinite.hs
  2. +22 −12 resources/static/hjs/jcu.hs
  3. +1 −1 src/JCU/Types.hs
@@ -9,7 +9,7 @@ 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 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
@@ -84,10 +84,9 @@ initialize = do -- Rendering
registerEvents $ [("#btnCheck" , "click" , toggleClue)
,("#btnAddRule", "click" , addRuleEvent)
- ,("#btnReset" , "click" , noevent)
+ ,("#btnReset" , "click" , resetTree)
,("#txtAddRule", "keypress", noevent)
- ,("#txtAddRule", "blur" , noevent)
- ,("#btnSubst" , "click" , noevent)
+ ,("#txtAddRule", "blur" , checkTermSyntax)
]
where noop :: AjaxCallback (JSPtr a)
noop = (\x y z -> return ())
@@ -96,6 +95,16 @@ initialize = do -- Rendering
toggleClue :: EventHandler
toggleClue _ = do toggleClassString "#proof-tree-div" "noClue"
return True
+ checkTermSyntax _ = do inp <- jQuery "#txtAddRule"
+ input <- valString inp
+ case tryParseTerm input of
+ Nothing -> do markInvalidTerm inp
+ _ -> return ()
+ return True
+ resetTree _ = do replaceRuleTree emptyProof
+ return True
+
+
emptyProof :: Proof
emptyProof = T.Node (Var "") []
@@ -159,15 +168,12 @@ buildRuleUl node status =
fCheck this _ = do term <- valString this
case tryParseTerm term of
(Just t) -> replaceRuleTree $ T.Node t []
- _ -> do removeClass this "blueField yellowField redField whiteField greenField"
- addClass this "blueField"
+ _ -> markInvalidTerm this
return False
replaceRuleTree :: Proof -> IO ()
replaceRuleTree p = do
- alert "start checkproof"
status <- checkProof p
- alert "end checkproof"
oldUL <- jQuery ruleTreeId
newUL <- buildRuleUl p status
@@ -220,20 +226,24 @@ 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
+ case tryParseTerm sub of
Nothing -> return False
- (Just t) -> do let newP = subst (Env $ fromList [(sub, t)]) p
+ (Just t) -> do let newP = subst (Env $ fromList [(for, t)]) p
replaceRuleTree newP
return True
+
+clearClasses :: JQuery -> IO ()
+clearClasses = flip removeClass "blueField yellowField redField whiteField greenField"
+
+markInvalidTerm :: JQuery -> IO ()
+markInvalidTerm jq = do clearClasses jq
+ addClass jq "blueField"
foreign import jscript "jQuery.noop()"
noop :: IO (JSFunPtr (JSPtr a -> String -> JSPtr b -> IO()))
View
@@ -83,7 +83,7 @@ mkJSONRule :: LBS.ByteString -> Rule
mkJSONRule = fst . startParse pRule . CSL
instance FromJSON Proof where
- parseJSON (Object o) = mkJSONProofTree <$> o .: "term" <*> o .: "childTerms"
+ parseJSON (Object o) = mkJSONProofTree <$> o .: "rootLabel" <*> o .: "childTerms"
parseJSON val = fail $ "No case for (FromJSON Proof) with value: " ++ show val
instance ToJSON Proof where

0 comments on commit dcb5877

Please sign in to comment.