diff options
Diffstat (limited to 'sucl')
| -rw-r--r-- | sucl/basic.icl | 6 | ||||
| -rw-r--r-- | sucl/newfold.icl | 70 | ||||
| -rw-r--r-- | sucl/newtest.icl | 38 |
3 files changed, 57 insertions, 57 deletions
diff --git a/sucl/basic.icl b/sucl/basic.icl index 1322f04..aa78e19 100644 --- a/sucl/basic.icl +++ b/sucl/basic.icl @@ -44,10 +44,10 @@ adjust a r f x // Claim a list of nodes from a heap claim :: ![.param] u:[.cell] -> ([.cell],v:[.cell]), [u<=v] -claim [] heap = ([],heap) <--- "basic.claim ends (with empty result)" +claim [] heap = ([],heap) claim [pnode:pnodes] [snode:heap] -= ([snode:snodes],heap`) <--- "basic.claim ends (with nonempty result)" - where (snodes,heap`) = (claim--->"basic.claim begins from basic.claim") pnodes heap += ([snode:snodes],heap`) + where (snodes,heap`) = claim pnodes heap claim pnodes emptyheap = abort "claim: out of heap" // Just in case. Should be used with an infinite heap. /* Depthfirst collects results of a function (called process), applied to a diff --git a/sucl/newfold.icl b/sucl/newfold.icl index ce3e653..28eb67b 100644 --- a/sucl/newfold.icl +++ b/sucl/newfold.icl @@ -117,9 +117,9 @@ fullfold :: & <<< pvar fullfold trc foldarea fnsymbol trace -| recursive ---> "newfold.fullfold begins" - = addlhs recurseresult <--- "newfold.fullfold ends (recursive=True)" -= addlhs (newextract trc foldarea trace) <--- "newfold.fullfold ends (recursive=False)" +| recursive + = addlhs recurseresult += addlhs (newextract trc foldarea trace) where (recursive,recurseresult) = recurse foldarea fnsymbol trace addlhs = mapsnd3 (pair (arguments rule)) (Trace _ rule _ _ _) = trace @@ -149,31 +149,31 @@ recurse :: & <<< pvar recurse foldarea fnsymbol -= ((f--->"newfold.recurse.f begins from newfold.recurse") ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins" += f ([],[]) where f newhisthist trace | (trace--->trace) $ False = error "shouldn't happen" f newhisthist (Trace stricts rule answer history (Reduce reductroot trace)) - | (isEmpty (pclosed--->"pclosed for isEmpty")--->"f: Reduce: isEmpty?") && (superset (popen--->"popen for superset") (ropen--->"ropen for superset")--->"f: Reduce: superset?") - = ((f--->"newfold.recurse.f begins (from Reduce)") (newhist`,newhist`) trace <--- "newfold.recurse.f ends (valid Reduce)") ---> "f: Reduce" + | isEmpty pclosed && superset popen ropen + = f (newhist`,newhist`) trace where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule - (pclosed,popen) = graphvars (rgraph--->"rgraph for (pclosed,popen)") (rargs--->"rargs for (pclosed,popen)") ---> "get (pclosed,popen)" - (_,ropen) = graphvars (rgraph--->"rgraph for ropen") [rroot--->"rroot for ropen"] ---> "get ropen" - newhist` = [(rroot,rgraph):newhist--->"newhist"] - (newhist,hist) = newhisthist ---> "get (newhist,hist)" + (pclosed,popen) = graphvars rgraph rargs + (_,ropen) = graphvars rgraph [rroot] + newhist` = [(rroot,rgraph):newhist] + (newhist,hist) = newhisthist f newhisthist (Trace stricts rule answer history (Annotate trace)) | isEmpty pclosed && superset popen ropen - = ((f--->"newfold.recurse.f begins (from Annotate)") (newhist`,hist) trace <--- "newfold.recurse.f ends (valid Annotate)") ---> "f: Annotate" + = f (newhist`,hist) trace where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule - (pclosed,popen) = graphvars rgraph rargs ---> "get (pclosed,popen)" - (_,ropen) = graphvars rgraph [rroot] ---> "get ropen" + (pclosed,popen) = graphvars rgraph rargs + (_,ropen) = graphvars rgraph [rroot] newhist` = [(rroot,rgraph):newhist] - (newhist,hist) = newhisthist ---> "get (newhist,hist)" + (newhist,hist) = newhisthist f newhisthist (Trace stricts rule answer history transf) - = ((foldtips--->"newfold.foldtips begins from newfold.recurse") foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf) <--- "newfold.recurse.f ends (other transformation)") ---> "f: default" + = foldtips foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf) where rroot = ruleroot rule; rgraph = rulegraph rule newhist` = [(rroot,rgraph):newhist] - (newhist,hist) = newhisthist ---> "get (newhist,hist)" + (newhist,hist) = newhisthist /* @@ -195,26 +195,26 @@ foldtips :: & == pvar foldtips foldarea foldcont -= (ft--->"newfold.foldtips.ft begins from foldtips")<---"newfold.foldtips ends" += ft where ft hist trace = case transf of Stop - -> (foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule) <--- "newfold.foldtips.ft ends (Stop)") ---> "newfold.foldtips.ft case = Stop" + -> foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule) where deltanodes = foldoptional [] getdeltanodes answer rnfnodes = foldoptional [ruleroot rule] (const []) answer Instantiate ipattern yestrace notrace - -> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Instantiate.match") hist yestrace) ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Instantiate.fail") hist notrace) - where ft` (False,yessra) (False,nosra) = (exres <--- "newfold.foldtips.ft ends (Instantiate/no)") ---> "newfold.foldtips.ft case Instantiate/no" + -> ft` (ft hist yestrace) (ft hist notrace) + where ft` (False,yessra) (False,nosra) = exres ft` (yesfound,(yesstricts,yesbody,yesareas)) (nofound,(nostricts,nobody,noareas)) - = ((True,(stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)") ---> "newfold.foldtips.ft case Instantiate/yes" + = (True,(stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas)) Reduce reductroot trace - -> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Reduce") (fst hist,fst hist) trace) - where ft` (False,sra) = (exres <--- "newfold.foldtips.ft ends (Reduce/no)") ---> "newfold.foldtips.ft case Reduce/no" - ft` (found,sra) = ((True,sra) <--- "newfold.foldtips.ft ends (Reduce/yes)") ---> "newfold.foldtips.ft case Reduce/no" + -> ft` (ft (fst hist,fst hist) trace) + where ft` (False,sra) = exres + ft` (found,sra) = (True,sra) Annotate trace - -> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Annotate") hist trace) - where ft` (False,sra) = (exres <--- "newfold.foldtips.ft ends (Annotate/no)") ---> "newfold.foldtips.ft case Annotate/no" - ft` (found,sra) = ((True,sra) <--- "newfold.foldtips.ft ends (Annotate/yes)") ---> "newfold.foldtips.ft case Annotate/no" + -> ft` (ft hist trace) + where ft` (False,sra) = exres + ft` (found,sra) = (True,sra) where (Trace stricts rule answer _ transf) = trace exres = (False,newextract noetrc foldarea trace) @@ -262,19 +262,19 @@ newextract :: & == pvar newextract trc newname (Trace stricts rule answer history transf) -| recursive ---> "newfold.newextract begins" - = (stricts,rule2body recrule,recareas) <--- "newfold.newextract ends (recursive=True)" +| recursive + = (stricts,rule2body recrule,recareas) = case transf of Reduce reductroot trace - -> newextract trc newname trace <--- "newfold.newextract ends (at Reduce transformation)" + -> newextract trc newname trace Annotate trace - -> newextract trc newname trace <--- "newfold.newextract ends (at Annotate transformation)" + -> newextract trc newname trace Instantiate ipattern yestrace notrace - -> (stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas) <--- "newfold.newextract ends (at Instantiate transformation)" + -> (stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas) where (_,yesbody,yesareas) = newextract trc newname yestrace (_,nobody,noareas) = newextract trc newname notrace Stop - -> (stricts,buildgraph rargs rroot stoprgraph,stopareas) <--- "newfold.newextract ends (at Stop transformation)" + -> (stricts,buildgraph rargs rroot stoprgraph,stopareas) where (recursive,unsafearea) = if (isreduce transf) @@ -296,7 +296,7 @@ buildgraph :: (Graph sym var) -> FuncBody sym var | == var buildgraph args root graph -= (BuildGraph (mkrgraph root (compilegraph (map (pairwith (snd o varcontents graph)) newnodes))) <--- "newfold.buildgraph ends") ---> "newfold.buildgraph begins" += BuildGraph (mkrgraph root (compilegraph (map (pairwith (snd o varcontents graph)) newnodes))) where newnodes = closedreplnodes--patnodes closedreplnodes = fst (graphvars graph [root]) patnodes = varlist graph args @@ -359,7 +359,7 @@ findpattern pattern thespinenodes residuroot transf findpattern pattern thespinenodes residuroot (Reduce reductroot trace) = fp (redirect residuroot) trace where fp residuroot (Trace stricts rule answer history transf) - | or [(isinstance--->"graph.isinstance begins from newfold.findpattern.fp") pattern (graph,node) \\ node<-varlist graph [residuroot]] + | or [isinstance pattern (graph,node) \\ node<-varlist graph [residuroot]] = True where graph = rulegraph rule fp residuroot trace = findpattern` pattern residuroot trace diff --git a/sucl/newtest.icl b/sucl/newtest.icl index ebe0f47..dbb1028 100644 --- a/sucl/newtest.icl +++ b/sucl/newtest.icl @@ -173,7 +173,7 @@ where toString srr instance <<< (Symredresult sym var tsym tvar) | toString sym & <<<,==,toString var where (<<<) file srr = file <<< "==[BEGIN]==" <<< nl - <<< "Task expression: " <<< ((srr.srr_task_expression <--- "newtest.<<<(Symredresult).srr_task_expression ends") ---> "newtest.<<<(Symredresult).srr_task_expression begins") <<< nl + <<< "Task expression: " <<< srr.srr_task_expression <<< nl <<< "Assigned symbol: " <<< toString (srr.srr_assigned_symbol) <<< nl <<< "Strictness: " <<< srr.srr_strictness <<< nl //<<< "Type rule: ..." <<< nl @@ -306,13 +306,13 @@ fullsymred :: fullsymred freshsymbols cli = results - where results = (depthfirst generate process (initareas cli) <--- "newtest.fullsymred.results ends") ---> "newtest.fullsymred.results begins" - generate result = (map canonise` (getareas result) <--- "newtest.fullsymred.generate begins") ---> "newtest.fullsymred.generate begins" - process area = (symredarea foldarea` cli area <--- "newtest.fullsymred.process ends") ---> "newtest.fullsymred.process begins" + where results = depthfirst generate process (initareas cli) + generate result = map canonise` (getareas result) + process area = symredarea foldarea` cli area - foldarea` = ((foldarea (labelarea` o canonise`)) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins" - labelarea` = (labelarea isSuclUserSym (map getinit results) freshsymbols <--- "newtest.fullsymred.labelarea` ends") ---> "newtest.fullsymred.labelarea` begins" - canonise` = (canonise (arity cli) suclheap <--- "newtest.fullsymred.canonise` ends") ---> "newtest.fullsymred.canonise` begins" + foldarea` = foldarea (labelarea` o canonise`) + labelarea` = labelarea isSuclUserSym (map getinit results) freshsymbols + canonise` = canonise (arity cli) suclheap isSuclUserSym (SuclUser _) = True isSuclUserSym _ = False @@ -349,11 +349,11 @@ initareas cli getinit :: (Symredresult sym var tsym tvar) -> Rgraph sym var getinit srr -= (srr.srr_task_expression <--- "newtest.getinit ends") ---> "newtest.getinit begins" += srr.srr_task_expression getareas :: (Symredresult sym var tsym tvar) -> [Rgraph sym var] getareas srr -= (srr.srr_areas <--- "newtest.getareas ends") ---> "newtest.getareas begins" += srr.srr_areas /* `Symredarea' is the function that does symbolic reduction of a single @@ -387,21 +387,21 @@ symredarea :: -> Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable symredarea foldarea cli area -= { srr_task_expression = (area <--- "newtest.symredarea.srr_task_expression ends") ---> "newtest.symredarea.srr_task_expression begins" - , srr_assigned_symbol = (symbol <--- "newtest.symredarea.srr_assigned_symbol ends") ---> "newtest.symredarea.srr_assigned_symbol begins" - , srr_strictness = (stricts <--- "newtest.symredarea.srr_strictness ends") ---> "newtest.symredarea.srr_strictness begins" += { srr_task_expression = area + , srr_assigned_symbol = symbol + , srr_strictness = stricts , srr_arity = length aargs , srr_typerule = trule - , srr_trace = (trace <--- "newtest.symredarea.srr_trace ends") ---> "newtest.symredarea.srr_trace begins" - , srr_function_def = (rules <--- "newtest.symredarea.srr_function_def ends") ---> "newtest.symredarea.srr_function_def begins" - , srr_areas = (areas <--- "newtest.symredarea.srr_areas ends") ---> "newtest.symredarea.srr_areas begins" + , srr_trace = trace + , srr_function_def = rules + , srr_areas = areas } where agraph = rgraphgraph area; aroot = rgraphroot area (symbol,aargs) = foldarea area arule = mkrule aargs aroot agraph - trule = (ruletype sucltypeheap (ctyperule SuclFN sucltypeheap (typerule cli)) arule <--- "newtest.symredarea.trule.ruletype ends") ---> "newtest.symredarea.trule.ruletype begins" - trace = (loop strategy` matchable` (suclheap--varlist agraph [aroot],arule) <--- "newtest.symredarea.trace.loop ends") ---> "newtest.symredarea.trace.loop begins" - (stricts,rules,areas) = (fullfold (trc symbol) foldarea symbol trace <--- "newtest.symredarea.(,,).fullfold ends") ---> "newtest.symredarea.(,,).fullfold begins" + trule = ruletype sucltypeheap (ctyperule SuclFN sucltypeheap (typerule cli)) arule + trace = loop strategy` matchable` (suclheap--varlist agraph [aroot],arule) + (stricts,rules,areas) = fullfold (trc symbol) foldarea symbol trace matchable` = matchable (complete cli) strategy` = clistrategy cli @@ -549,7 +549,7 @@ ctyperule fn typeheap typerule (sym,args) = mkrule targs` troot` tgraph` where targs = arguments trule; troot = ruleroot trule; tgraph = rulegraph trule trule = typerule sym - (targs`,targs``) = (claim--->"basic.claim begins from newtest.ctyperule") args targs + (targs`,targs``) = claim args targs (troot`,tgraph`,_) = foldr build (troot,tgraph,typeheap--varlist tgraph [troot:targs]) targs`` build targ (troot,tgraph,[tnode:tnodes]) = (tnode,updategraph tnode (fn 1,[targ,troot]) tgraph,tnodes) |