{-# LANGUAGE Rank2Types #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE TypeSynonymInstances #-}{-# LANGUAGE FlexibleInstances #-}moduleLanguage.Prolog.NanoProlog.Lib(LowerCase,Result(..),Rule((:<-:)),Subst(..),Taggable(..),Term(..),emptyEnv,enumerateDepthFirst,pFun,pRule,pTerm,show',solve,startParse,unify)whereimportData.ListLike.Base(ListLike)importData.List(intercalate)importData.Map(Map)importqualifiedData.MapasMimportText.ParserCombinators.UUimportText.ParserCombinators.UU.BasicInstancesimportText.ParserCombinators.UU.Utils-- * TypestypeUpperCase=StringtypeLowerCase=StringdataTerm=VarUpperCase|FunLowerCase[Term]deriving(Eq,Ord)dataRule=Term:<-:[Term]derivingEqclassTaggableawheretag::Int->a->ainstanceTaggableTermwheretagn(Varx)=Var(x++shown)tagn(Funxxs)=Funx(tagnxs)instanceTaggableRulewheretagn(c:<-:cs)=tagnc:<-:tagncsinstanceTaggablea=>Taggable[a]wheretagn=map(tagn)typeEnv=MapUpperCaseTermemptyEnv::Maybe(MapUpperCaset)emptyEnv=JustM.empty-- * The Prolog machinerydataResult=None|DoneEnv|ApplyRules[(Rule,Result)]classSubsttwheresubst::Env->t->tinstanceSubsta=>Subst[a]wheresubste=map(subste)instanceSubstTermwheresubstenv(Varx)=maybe(Varx)(substenv)(M.lookupxenv)substenv(Funxcs)=Funx(substenvcs)instanceSubstRulewheresubstenv(c:<-:cs)=substenvc:<-:substenvcsunify::(Term,Term)->MaybeEnv->MaybeEnvunify_Nothing=Nothingunify(t,u)env@(Justm)=uni(substmt)(substmu)whereuni(Varx)y=Just(M.insertxym)unix(Vary)=Just(M.insertyxm)uni(Funxxs)(Funyys)|x==y&&lengthxs==lengthys=foldrunifyenv(zipxsys)|otherwise=Nothingsolve::[Rule]->MaybeEnv->Int->[Term]->Resultsolve_Nothing__=Nonesolve_(Juste)_[]=Doneesolverulesen(t:ts)=ApplyRules[(rule,solverules(unify(t,c)e)(n+1)(cs++ts))|rule@(c:<-:cs)<-tagnrules]-- ** Printing the solutions | `enumerateBreadthFirst` performs a-- depth-first walk over the `Result` tree, while accumulating the-- rules that were applied on the path which was traversed from the-- root to the current node. At a successful leaf this contains the-- full proof.enumerateDepthFirst::[(String,Rule)]->[String]->Result->[([(String,Rule)],Env)]enumerateDepthFirstproofs_(Doneenv)=[(proofs,env)]enumerateDepthFirstproofs_None=[]enumerateDepthFirstproofs(pr:prefixes)(ApplyRulesbs)=[s|(rule@(c:<-:cs),subTree)<-bs,letextraPrefixes=take(lengthcs)(map(\i->pr++"."++showi)[1..]),s<-enumerateDepthFirst((pr,rule):proofs)(extraPrefixes++prefixes)subTree]{-
-- | `enumerateBreadthFirst` is still undefined, and is left as an
-- exercise to the JCU students
enumerateBreadthFirst :: [(String, Rule)] -> [String] -> Result -> [([(String, Rule)], Env)]
-}-- | `printEnv` prints a single solution, showing only the variables-- that were introduced in the original goalshow'::Env->[Char]show'env=intercalate", ".filter(not.null).mapshowBdg$M.assocsenvwhereshowBdg(x,t)|isGlobVarx=x++" <- "++showTermt|otherwise=""showTermt@(Var_)=showTerm(substenvt)showTerm(Funf[])=fshowTerm(Funfts)=f++"("++intercalate", "(mapshowTermts)++")"isGlobVarx=headx`elem`['A'..'Z']&&lastx`notElem`['0'..'9']instanceShowTermwhereshow(Vari)=ishow(Funi[])=ishow(Funits)=i++"("++showCommasts++")"instanceShowRulewhereshow(t:<-:[])=showt++"."show(t:<-:ts)=showt++":-"++showCommasts++"."showCommas::Showa=>[a]->StringshowCommasl=intercalate", "(mapshowl)-- ** Parsing Rules and TermsstartParse::(ListLikesb,Showb)=>P(StrbsLineColPos)a->s->(a,[ErrorLineColPos])startParsepinp=parse((,)<$>p<*>pEnd)$createStr(LineColPos000)inppTerm,pVar,pFun::ParserTermpTerm=pVar<|>pFunpVar=Var<$>lexeme(pList1pUpper)pFun=Fun<$>pLowerCase<*>(pParenspTerms`opt`[])wherepLowerCase::ParserStringpLowerCase=(:)<$>pLower<*>lexeme(pList(pLetter<|>pDigit))pRule::ParserRulepRule=(:<-:)<$>pFun<*>(pSymbol":-"*>pTerms`opt`[])<*pDotpTerms::Parser[Term]pTerms=pListSeppCommapTerm