Exploratory Haskell (2015)

09 Dec 2015

It doesn’t have to be so thought out.

A lot of people think that Haskell is great for expressing a problem that you understand really well, but it’s not so great for sketching out a problem and prototyping. In Ruby, you can start writing code that kinda works, and refine it to be more and more correct. In Haskell, you really have to get the code to type check before you do anything else, and if you don’t have a good idea of your data model, then you don’t have types to work with, and you can’t really make it all work. Right?

I’m fortunate enough to be able to pick whatever language I want to solve programming problems in my Artificial Intelligence course at UGA. One assignment was to implement the DPLL algorithm from the textbook (Russell and Norvig). I decided to copy the pseudocode, translate it directly into Haskell, and see if I could get to a working solution from there. The Wikipedia article linked does a good job explaining the algorithm, so I’ll just go over the code. Very briefly, the algorithm is a way of taking a list of clauses of Boolean logic and determining whether or not there is a way to assign the variables in the clauses to make the whole expression true.

The original code is available in this repository.

The Pseudocode

Here is the pseudocode for the algorithm, reproduced from Norvig and Russell’s textbook:

function DPLL(clauses, symbols, model ) returns true or false
    if every clause in clauses is true in model then
        return true
    if some clause in clauses is false in model then 
        return false
    P, value ← FIND-PURE-SYMBOL (symbols, clauses, model)
    if P is non-null then 
        return DPLL(clauses, symbols – P, model ∪ {P =value})
    P, value ← FIND-UNIT-CLAUSE (clauses, model)
    if P is non-null then
        return DPLL(clauses, symbols – P, model ∪ {P =value})
    P ← FIRST (symbols)
    rest ← REST (symbols)
    return DPLL(clauses, rest, model ∪ {P =true}) 
        or DPLL(clauses, rest, model ∪ {P =false}))

Now let’s make it Haskell! We’ll translate names and terms directly and assume functions exist that we can use. We already know that P can be nullable, so we’ll go ahead and use Maybe for that type. Instead of if checking, we’ll pattern match on the result.

dpll::Clauses->Symbols->Model->Booldpllclausessymbolsmodel=ifall(`isTrueIn`model)clausesthenTrueelseifany(`isFalseIn`model)clausesthenFalseelsecasefindPureSymbolsymbolsclausesmodelof(Justsym,val)->dpllclauses(symbols`minus`sym)(model`including`(sym:=val))(Nothing,val)->casefindUnitClauseclausesmodelof(Justsym,val)->dpllclauses(symbols`minus`sym)(model`including`(sym:=val))(Nothing,val)->casesymbolsof(x:xs)->dpllclausesxs(model`including`(x:=False))||dpllclausesxs(model`including`(x:=True))[]->False-- should not happen?

This doesn’t compile or type check at all. Despite that, hlint is capable of suggesting code improvements, and we can follow those to a much nicer looking implementation. Here’s a mostly syntastic transformation to the above code:

dpll::Clauses->Symbols->Model->Booldpllclausessymbolsmodel|all(`isTrueIn`model)clauses=True|any(`isFalseIn`model)clauses=False|otherwise=casefindPureSymbolsymbolsclausesmodelofJust(sym:=val)->dpllclauses(symbols`minus`sym)(model`including`(sym:=val))Nothing->casefindUnitClauseclausesmodelofJust(sym:=val)->dpllclauses(symbols`minus`sym)(model`including`(sym:=val))Nothing->casesymbolsof(x:xs)->dpllclausesxs(model`including`(x:=False))||dpllclausesxs(model`including`(x:=True))[]->False-- really why

The “pattern matching on Maybe” approach is kind of ugly. Let’s extract those branches into named subexpressions and use maybe from Data.Maybe to choose which branch to go on, and pattern match directly on the list at the function definition rather than later on.

dpll::Clauses->Symbols->Model->Booldpllclausessymbols@(x:xs)model|all(`isTrueIn`model)clauses=True|any(`isFalseIn`model)clauses=False|otherwise=maybepureSymbolNothingpureSymbolJust(findPureSymbolsymbolsclausesmodel)wherepureSymbolJust(sym:=val)=dpllclauses(symbols`minus`sym)(model`including`(sym:=val))pureSymbolNothing=maybeunitClauseNothingunitClauseJust(findUnitClauseclausesmodel)unitClauseJust(sym:=val)=dpllclauses(symbols`minus`sym)(model`including`(sym:=val))unitClauseNothing=dpllclausesxs(model`including`(x:=False))||dpllclausesxs(model`including`(x:=True))

We’ve eliminated the manual pattern matching. While more astute programmers might have noticed what’s going on with the previous form, I didn’t quite catch on to the overall pattern. Note that we’re doing the same thing in every terminal branch: we recursively call dpll, and only the variable assignment changes! More than that, we’re expressing the idea of “Try this thing. If it succeeds, take the result. If it fails, try the next thing.”

The Maybe monad captures a similar idea, but isn’t quite what we want – that returns Nothing if any are Nothing, and really, we want to take the first Just value and do something with it.

Maybe has an Alternative instance, which does exactly what we want:

>Nothing<|>Just10<|>Nothing<|>Just2Just10

One of the cool things we can do with an Alternative is the asum function. We give it a Foldable t full of Alternative f => f a values, and it gives us back an f a based on the definition of Alternative for our f. We can very succinctly express the idea “Try these actions and take the first successful one” with this!

Alright, let’s refactor our code to use that idea. We’re using the Maybe functor all over the place, so to bring dpll in line with the find functions, we’ll return a Maybe Model. This makes the function even more useful – now you get back the model instead of just whether or not the statement is satisfiable!

dpll::Clauses->Symbols->Model->MaybeModeldpllclausessymbolsmodel|all(`isTrueIn`model)clauses=Justmodel|any(`isFalseIn`model)clauses=Nothing|otherwise=letcontrolList::[MaybeAssignment]controlList=[findPureSymbolsymbolsclausesmodel,findUnitClauseclausesmodel,(:=False)<$>listToMaybesymbols,(:=True)<$>listToMaybesymbols]

controlList is our list of possible assignments. We want to take the first one that actually works and do something with it.

next::Assignment->MaybeModelnext(sym:=val)=dpllclauses(symbols`minus`sym)(model`including`(sym:=val))

The next step is taking the assignment, and recursively calling dpll with the symbol removed from the symbol collection and the model including the assignment.

And now, for the expression that puts everything together:

inasum(map(>>=next)controlList)

Haskell’s laziness works well for us here. In a strict language, this code would generate all possible models before picking the first one. We can really leverage Haskell’s laziness to make this efficient and fast.

“uh but it still doesn’t compile”

So we’ve taken a pseudocode algorithm, translated it to Haskell, and applied a bunch of Haskell idioms to it. There are no type definitions, and the code doesn’t compile, and virtually no functions are defined. Now I guess we’ll want to fill in those lower level details with stuff that fits what we want.

Let’s analyze what we’re doing with the terms to get some idea of what data types will fit for them. A symbol could be anything – but we’ll just use a String for now.

I’ve used listToMaybe on the symbols. This betrays my intent – Symbols is going to be a list. That gives us enough information to define minus as well.

typeSymbols=[Symbol]minus::Symbols->Symbol->Symbolsminusxs=(xs\\).pure-- or, if you don't like point-free,minusxsx=xs\\[x]

The Clauses type is a collection of expressions. An expression is a list of terms in Conjunctive Normal Form (CNF).

With CNF, juxtaposion is conjunction. We can therefore represent a CNF expression as a list of literals:

Finally, a literal is a pair of Sign and Symbol.

typeLiteral=(Sign,Symbol)

A sign is a function that either negates or doesn’t negate a boolean expression.

dataSign=Pos|Negderiving(Eq,Ord,Show)apply::Sign->Bool->BoolapplyPos=idapplyNeg=not-- some helper functions for testingn::Symbol->Literalnc=(Neg,c)p::Symbol->Literalpc=(Pos,c)

We can now actually construct an example Clauses to test our function (when it, you know, compiles):

ex::Clausesex=[[n"p",p"a",p"c"],[n"a"],[p"p",n"c"]]

The main use we have for the clauses type is to map over it with isTrueIn and isFalseIn, checking every clause in the list against the model. The model is an assignment of symbols to truth values, and random access time is important. We’ll use a map.

typeModel=MapSymbolBoolisTrueIn::CNF->Model->BoolisTrueIncnfmodel=or(mapMaybefcnf)wheref(sign,symbol)=applysign<$>Map.lookupsymbolmodel

Here, we’re looking up every symbol in the CNF expression, and applying the literal’s sign to the possible value. If there’s no value in the model, then it doesn’t return anything. or checks to see if there are any True values in the resulting list. If there are, then the CNF is true in the model.

isFalseIn::CNF->Model->BoolisFalseIncnfmodel=allnotliteralswhereliterals=mapfcnff(sign,symbol)=applysign(Map.findWithDefault(applysignTrue)symbolmodel)

isFalseIn is trickier – we map over the CNF expression with a default value of the sign applied to True. Then, we apply the sign again to the resulting value.all not is a way of saying “every element is false.”

Now the compiler is complaining about not recognizing the := symbol. As it happens, any infix function that prefixed with a : is a data constructor. We’ll define the data type Assignment and give it some accessor functions.

dataAssignment=(:=){getSymbol::Symbol,getValue::Bool}instanceShowAssignmentwhereshow(s:=v)="("++s++" := "++showv++")"

An advantage of using a data constructor is that we can pattern match on the values of that constructor. This gives us a rather nice definition of the including function:

including::Model->Assignment->Modelincludingm(sym:=val)=Map.insertsymvalm

The final remaining items that aren’t defined are findPureSymbol and findUnitClause. From the textbook,

Pure symbol heuristic: A pure symbol is a symbol that always appears with the same “sign” in all clauses. For example, in the three clauses (A ∨ ¬ B), (¬ B ∨ ¬ C), and (C ∨ A), the symbol A is pure because only the positive literal appears, B is pure because only the negative literal appears, and C is impure.

If a symbol has all negative signs, then the returned assignment is False. If a symbol has all positive signs, then the returned assignment is True. We’ll punt refining the clauses with the model to a future function…

findPureSymbol::Symbols->Clauses->Model->MaybeAssignmentfindPureSymbolsymbolsclauses'model=asum(mapmakeAssignmentsymbols)whereclauses=refinePureclauses'modelmakeAssignment::Symbol->MaybeAssignmentmakeAssignmentsym=(sym:=)<$>negOrPos(signsForSymbolsym)

We’re using asum again to pick the first assignment that works out. This maps the assignment of the sym variable over the negOrPos function, which determines whether the symbol should have a True or False assignment.

signsForSymbol::Symbol->[Sign]signsForSymbolsym=clauses>>=signsForSymInClausesymsignsForSymInClause::Symbol->CNF->[Sign]signsForSymInClausesym=mapfst.filter((==sym).snd)

So we’re filtering the CNF (a list of Literals or (Sign, Symbol)) to only contain the elements whose second element is equal to the symbol. And then we’re extracting the first element, leaving just the Signs.

negOrPos::[Sign]->MaybeBoolnegOrPos=getSingleton.nubgetSingleton::[a]->MaybeagetSingleton[x]=JustxgetSingleton_=Nothing

Finally, we nub the list, and if it’s a singleton, then we have a success.

Now, we’ll define the findUnitClause function. From the textbook,

Unit clause heuristic: A unit clause was defined earlier as a clause with just one literal. In the context of DPLL, it also means clauses in which all literals but one are already assigned false by the model. For example, if the model contains B = true, then (¬B ∨ ¬C) simplifies to ¬C, which is a unit clause. Obviously, for this clause to be true, C must be set to false. The unit clause heuristic assigns all such symbols before branching on the remainder.

As above, we’ll punt refining the clauses with the model until later.

findUnitClause::Clauses->Model->MaybeAssignmentfindUnitClauseclauses'model=assignSymbol<$>firstUnitClausewhereclauses::Clausesclauses=refineUnitclauses'modelfirstUnitClause::MaybeLiteralfirstUnitClause=asum(map(getSingleton.mapMaybeifInModel)clauses)ifInModel::Literal->MaybeLiteralifInModel(sign,symbol)=caseMap.lookupsymbolmodelofJustval->ifapplysignvalthenNothingelseJust(sign,symbol)_->Just(sign,symbol)assignSymbol::Literal->AssignmentassignSymbol(sign,symbol)=symbol:=applysignTrue

This is much simpler than pure symbols! We map assignment over the first unit clause that is found. The first unit clause is found with the asum technique. We take the list of clauses, and for each clause, first determine what to do if it’s in the model already. If the symbol is in the model, then we check to see if the literal in the clause has a True or False value by applying the sign to the value. If the value is True, then we don’t include it. Otherwise, we include the literal in the list. Finally, we attempt to get the singleton list. asum gets the first clause which satisfies these conditions.

Now, in the previous functions, we punted refining the clauses. It’s time to do that. For a pure symbol, the given optimization is (from the book):

Note that, in determining the purity of a symbol, the algorithm can ignore clauses that are already known to be true in the model constructed so far. For example, if the model contains B = false, then the clause (¬ B ∨ ¬ C) is already true, and in the remaining clauses C appears only as a positive literal; therefore C becomes pure.

We’ll start by folding the model and clauses into a new set of clauses. The helper function will go through each symbol in the model, find the relevant clauses, and modify them appropriately.

refinePure::Clauses->Model->ClausesrefinePure=Map.foldrWithKeyfwheref::Symbol->Bool->Clauses->Clausesfsymval=mapdiscardTruewherediscardTrue=filter(not.clauseIsTrue)clauseIsTrue(sign,symbol)=symbol==sym&&applysignval

The optimization from the text for the unit clause is:

In the context of DPLL, it also means clauses in which all literals but one are already assigned false by the model. For example, if the model contains B = true, then (¬ B ∨ ¬ C) simplifies to ¬ C, which is a unit clause. Obviously, for this clause to be true, C must be set to false. The unit clause heuristic assigns all such symbols before branching on the remainder.

refineUnit::Clauses->Model->ClausesrefineUnitclausesmodel=maprefineclauseswhererefine::CNF->CNFrefinecnf=caseallButOneFalsecnfofJust(s:=True)->[ps]Just(s:=False)->[ns]Nothing->cnfallButOneFalse::CNF->MaybeAssignmentallButOneFalse=getSingleton.filter(not.getValue).mapassignassign::Literal->Assignmentassign(sign,sym)=sym:=Map.findWithDefault(applysignTrue)symmodel

If all but one of the literals in the CNF are false, then we return that with the proper assigment. Otherwise, we return the whole CNF expression.

Starting from a straight up transcription, we’ve now finally implemented enough to solve problems!

solved::MaybeModelsolved=dpllex["p","a","c"]Map.empty

The output will be kind of ugly, so let’s make a pretty printing function:

showModel::Model->StringshowModel=unlines.map(show.snd).Map.toList.Map.mapWithKey(:=)

Evaluating solved in GHCi gives us:

Prelude HW6> putStr . showModel . fromJust $ solved
(a := False)
(c := False)
(p := False)

Assigning the variables with those values does return a true model. Nice!

Australia

Given a set of colors, and a map, can you color every state in a way that all touching states have different colors?

This is the coloring problem (with a good intro here). As it happens, Australia makes a nice simple model for this, and the three coloring of Australia is easy enough to do by hand that it makes a good model for testing our software out. Let’s define the problem and find the solution!

First, we’ll want to define our symbols:

colors::[Symbol]colors=[green,blue,red]green="-green"blue="-blue"red="-red"states::[Symbol]states=[western,southern,northern,queensland,newSouthWales,victoria]western="Western"southern="Southern"northern="Northern"queensland="Queensland"newSouthWales="New South Wales"victoria="Victoria"

Now we’ll express that a given state can have one color, but only one:

hasColor::Symbol->ClauseshasColorst=[[p$st`is`green,p$st`is`blue,p$st`is`red],[n$st`is`blue,n$st`is`red],[n$st`is`green,n$st`is`red],[n$st`is`green,n$st`is`blue]]

Since our symbols are lists, we can concatenate them together. We don’t want to get the two confused, so we make specialized functions that only work on symbols and clauses, respectively.

is::Symbol->Symbol->Symbolis=(++)(/\)::Clauses->Clauses->Clauses(/\)=(++)

And, since we’ll often want to take a list of things, apply a function to each, and make a clause out of the whole thing, we’ll alias the bind function to something that looks kind of like “take the conjunction of this whole set.”

(/\:)::Monadm=>ma->(a->mb)->mb(/\:)=(>>=)

At first, we’ll simply say that every state has a color.

initialConditions::ClausesinitialConditions=states/\:hasColor

Next, we’ll say that for a pair of adjacent states, they can’t both be the same color.

adjNotEqual::(Symbol,Symbol)->ClausesadjNotEqual(a,b)=colors/\:bothAreNotwherebothAreNotcolor=[[n$a`is`color,n$b`is`color]]

Next, a list of adjacent states…

adjStates::[(Symbol,Symbol)]adjStates=[(western,northern),(western,southern),(northern,southern),(northern,queensland),(southern,newSouthWales),(southern,victoria),(southern,queensland),(newSouthWales,queensland),(newSouthWales,victoria)]adjacentStatesNotEqual::ClausesadjacentStatesNotEqual=adjStates/\:adjNotEqualaustraliaClauses::ClausesaustraliaClauses=initialConditions/\adjacentStatesNotEqualaustraliaSymbols::SymbolsaustraliaSymbols=is<$>states<*>colors

Now, we’ve finally accomplished the encoding, and we can get the solution.

australiaSolution::MaybeModelaustraliaSolution=dpllaustraliaClausesaustraliaSymbolsmempty

It can be printed with the following function:

showOnlyTrue::Model->StringshowOnlyTrue=unlines.map(show.snd).filter(getValue.snd).Map.toList.Map.mapWithKey(:=)printAustralia::IO()printAustralia=doletmodel=fromJustaustraliaSolutionputStrLn(showOnlyTruemodel)

Which, when evaluated in GHCi, gives us:

Prelude HW6> printAustralia
(New South Wales-red := True)
(Northern-red := True)
(Queensland-blue := True)
(Southern-green := True)
(Victoria-blue := True)
(Western-blue := True)

This can be verified manually to be a correct coloring of Australia.

Well, we started with a bunch of pseudocode, transcribed it directly into Haskell syntax, refactored it blindly until it was nice and idiomatic, and finally started implementing the details we’d assumed. This is rather different from how I usually approach solving problems in Haskell, and it was pretty fun.