Permalink
Browse files

* Drag + drop = working

* Still error in the parser
  • Loading branch information...
1 parent bd560c0 commit 1db0892c68528122e72685abbab7ce935b7552ca @spockz committed Jan 5, 2012
@@ -788,4 +788,10 @@ var i={};i[g]=(f=="show"?b=="pos"?"+=":"-=":b=="pos"?"-=":"+=")+e;a.animate(i,{q
*/
(function(e){e.effects.transfer=function(a){return this.queue(function(){var b=e(this),c=e(a.options.to),d=c.offset();c={top:d.top,left:d.left,height:c.innerHeight(),width:c.innerWidth()};d=b.offset();var f=e('<div class="ui-effects-transfer"></div>').appendTo(document.body).addClass(a.options.className).css({top:d.top,left:d.left,height:b.innerHeight(),width:b.innerWidth(),position:"absolute"}).animate(c,a.duration,a.options.easing,function(){f.remove();a.callback&&a.callback.apply(b[0],arguments);
b.dequeue()})})}})(jQuery);
-;
+;
+
+function wrappedJQueryUIEvent(cps) {
+ return function (event, ui) {
+ return cps(jQuery(this), event, ui)
+ }
+}
@@ -4,6 +4,12 @@ import Language.UHC.JScript.ECMA.String
import Language.UHC.JScript.Primitives
import Language.UHC.JScript.Types
+import Data.List (find)
+
+import ParseLib.Abstract
+import Language.Prolog.NanoProlog.NanoProlog
+import Language.Prolog.NanoProlog.ParserUUTC
+
type ProofResult = String -- I want to make an enum of this
@@ -37,6 +43,14 @@ proofTreeNode = Node "" "" [] ""
foreign import jscript "%1.rule"
getRule :: JSRule -> JSString
+
+hasValidSyntax :: String -> Bool
+hasValidSyntax term =
+ maybe False (const True) (run pTerm term)
+
+
+run :: Parser a b -> [a] -> Maybe b
+run p as = fmap fst . find (null . snd) $ startParse p as
-- class exports.ProofTreeNode extends Backbone.Model
-- # Available attributes:
@@ -3,8 +3,11 @@ module Templates where
home = "<div class=\"yui3-g\"> <div class=\"yui3-u-1-2\"> <div class=\"content\"> <h2>Proof Tree</h2> <div id=\"proof-tree-div\"><!-- TREE GOES HERE --></div> <div id=\"subst\">Substitute <input type=\"text\" id=\"txtSubstSub\" style=\"width: 50px\" /> for <input type=\"text\" id=\"txtSubstFor\" style=\"width: 50px\" /> <input type=\"button\" id=\"btnSubst\" value=\"Substitute\" /> (e.g. substitute bea for X0) </div> <input type=\"button\" id=\"btnCheck\" value=\"Check Proof\" /> <input type=\"button\" id=\"btnReset\" value=\"Reset Tree\" /> <!-- <h3>Note</h3> <p class=\"lhsText\">Due to limitations in the current version of the software, you might see variables with the same name in different text fields in the tree. However, these are not necessarily the same variable! Double-check to see which rules you can apply and which variables those rules have.</p> --> <h3>Color coding help</h3> <ul id=\"color-coding-list\"> <li><div class=\"box redField\"></div> Incorrect rule application</li> <li><div class=\"box yellowField\"></div> Incomplete proof</li> <li><div class=\"box greenField\"></div> Correct rule</li> <li><div class=\"box blueField\"></div> Syntax error</li> </ul> <h3>Example data</h3> <p class=\"lhsText\"> Example data containing the Dutch royal family, the list structure and lookup, and the natural numbers (as discussed in the JCU lecture notes) can be loaded by <a href=\"/load-example\">clicking this link</a>. Beware that this will replace all your existing rules! </p> </div> </div> <div class=\"yui3-u-1-2\"> <div class=\"content\"> <h2>Stored Rules</h2> <p>Drag a rule form the list below to a field containing a term in the tree on the left.</p> <div id=\"rules-list-div\"><!-- LIST GOES HERE --></div> <div id=\"divListAdd\"> <input type=\"text\" id=\"txtAddRule\" /> <input type=\"button\" value=\"Add\" id=\"btnAddRule\" /> </div> </div> </div></div>"
proof_tree_item term treeLbl disabled =
- "<div class=\"tree_item dropzone\"> " ++ treeLbl ++ ". <input type=\"text\" id=\"proof_" ++ treeLbl ++ "\" " ++ if disabled then " disabled=\"disabled\"" else "" ++ " class=\"droppable\" value=\"" ++ term ++ "\" /></div>"
-
+ "<div class=\"tree_item dropzone\"> " ++ treeLbl ++
+ ". <input type=\"text\" class=\"droppable\" id=\"proof_" ++ treeLbl ++ "\" value=\"" ++ term ++ "\"" ++ disabled' ++ " /></div>"
+ where
+ disabled' = if disabled then " disabled=\"disabled\"" else ""
+
rules_list_item :: String -> String
rules_list_item rule =
let rule_replaced = rule -- replace /[^a-zA-Z0-9]+/g, ""
@@ -1,7 +1,7 @@
{-# LANGUAGE EmptyDataDecls #-}
module JCU where
-import Control.Monad (liftM)
+import Control.Monad (liftM, foldM)
import Data.List
@@ -21,6 +21,10 @@ import Language.UHC.JScript.Assorted (alert , _alert)
import Language.UHC.JScript.JQuery.Ajax as Ajax
import qualified Language.UHC.JScript.JQuery.AjaxQueue as AQ
import Language.UHC.JScript.JQuery.Draggable
+import Language.UHC.JScript.JQuery.Droppable
+
+import Language.Prolog.NanoProlog.NanoProlog
+import Language.Prolog.NanoProlog.ParserUUTC
----
-- App
@@ -69,6 +73,8 @@ initialize = do -- Rendering
-- Rules list
ajaxQ "/rules/stored" addRules noop
+ addRuleTree
+
registerEvents $ [("#btnCheck" , "click" , noevent)
,("#btnAddRule", "click" , noevent)
@@ -82,6 +88,67 @@ initialize = do -- Rendering
noevent :: EventHandler
noevent x = return False
+addRuleTree :: IO ()
+addRuleTree = do
+ ruleTreeDiv <- jQuery "#proof-tree-div"
+ ruleTreeUL <- buildRuleUl $ Node "" "" [] ""
+ append ruleTreeDiv ruleTreeUL
+
+buildRuleUl :: ProofTreeNode -> IO JQuery
+buildRuleUl node =
+ do topUL <- jQuery "<ul id=\"proof-tree-view\" class=\"tree\"/>"
+ restUL <- build' node False
+ append topUL restUL
+ return topUL
+ where
+ f :: JQuery -> ProofTreeNode -> IO JQuery
+ f jq node = do li' <- build' node True
+ append jq li'
+ return jq
+ dropje :: ProofTreeNode -> UIThisEventHandler
+ dropje node this _ _ = do
+ elem <- findSelector this "input[type='text']:first"
+ elemVal <- valString elem
+
+ if length elemVal == 0 then
+ alert "There needs to be a term in the text field!"
+ else
+ if hasValidSyntax (fromJS elemVal) then
+ alert "Jeej! TODO: Actual unification and storing of result. :)"
+ else
+ alert "You cannot possibly think I could unify this invalid term!"
+
+ return True
+ -- elemVal = $(this).find("input[type='text']:first").val()
+ -- if !elemVal
+ -- alert "There needs to be a term in the text field!"
+ -- @
+ -- else
+ -- view.model.setTerm elemVal
+ --
+ -- if !view.model.hasValidSyntax()
+ -- alert "Cannot unify with an invalid term!"
+ -- @
+ -- else
+ -- view.unify view.model.get("treeLvl"), elemVal, ui.draggable.find(".rule-text").html()
+
+ build' :: ProofTreeNode -> Bool -> IO JQuery
+ build' n@(Node term mcid childTerms proofResult) disabled =
+ do li <- jQuery "<li/>"
+ appendString li $ proof_tree_item term "" disabled
+
+ dropzones <- findSelector li ".dropzone"
+
+ drop' <- mkJUIThisEventHandler (dropje n)
+ drop'' <- wrappedJQueryUIEvent drop'
+ droppable dropzones $ Droppable (toJS "dropHover") drop''
+
+
+ startUl <- jQuery "<ul/>"
+ res <- foldM f startUl childTerms
+ append li res
+ return li
+
addRules :: AjaxCallback (JSArray JSRule)
addRules obj str obj2 = do
@@ -113,5 +180,7 @@ foreign import jscript "wrapper"
foreign import jscript "wrapper"
ioWrap :: IO () -> IO (JSFunPtr (IO ()))
+
+
alertType :: a -> IO ()
alertType = _alert . typeof
@@ -1,4 +1,4 @@
-COMPILER = ${UHC} --import-path=${UHC_JSCRIPT} -tjscript --no-recomp --no-hi-check -O,2 # --dump-core-stages=1
+COMPILER = ${UHC} --import-path=${UHC_JSCRIPT} --import-path=${UHC_NANOPROLOG} --import-path=${UHC_UU_TC} -tjscript --no-recomp --no-hi-check -O,2 # --dump-core-stages=1
all: build
@@ -11,6 +11,6 @@ testcase: testcases/*.hs
test:
echo $(GHC_OPTS)
-clean-core:
+.PHONY clean-core:
rm `find . -d -name "*.core*"`
rm `find ${LANGUAGE_DIR} -d -name "*.core*"`

0 comments on commit 1db0892

Please sign in to comment.