packages feed

jukebox 0.1.6 → 0.2

raw patch · 59 files changed

+4215/−4687 lines, 59 filesdep +dlistdep +symboldep +transformersdep −bytestringdep −hashabledep −mtl

Dependencies added: dlist, symbol, transformers, uglymemo

Dependencies removed: bytestring, hashable, mtl

Files

− Jukebox/Clausify.hs 
@@ -1,446 +0,0 @@-{-# LANGUAGE TypeOperators, BangPatterns #-}-module Jukebox.Clausify where--import Jukebox.Form-import qualified Jukebox.Form as Form-import Jukebox.Name-import Data.List( maximumBy, sortBy, partition )-import Data.Ord-import Control.Monad.Reader-import Control.Monad.State.Strict-import qualified Jukebox.Seq as S-import Jukebox.Seq(Seq)-import qualified Jukebox.NameMap as NameMap-import Jukebox.NameMap(NameMap)-import qualified Jukebox.Map as Map-import qualified Data.HashSet as Set-import qualified Data.ByteString.Char8 as BS-import Jukebox.Utils-import Jukebox.Options-import Control.Applicative--newtype ClausifyFlags = ClausifyFlags { splitting :: Bool } deriving Show--clausifyFlags =-  inGroup "Clausifier options" $-  ClausifyFlags <$>-    bool "split"-      ["Split the conjecture into several sub-conjectures.",-       "Default: (off)"]--------------------------------------------------------------------------- clausify--clausify :: ClausifyFlags -> Problem Form -> CNF-clausify flags inps = close inps (run . clausifyInputs S.Nil S.Nil)- where-  clausifyInputs theory obligs [] =-    do return (toObligs (S.toList theory) (S.toList obligs))-  -  clausifyInputs theory obligs (inp:inps) | kind inp == Axiom =-    do cs <- clausForm (tag inp) (what inp)-       clausifyInputs (theory `S.append` cs) obligs inps--  clausifyInputs theory obligs (inp:inps) | kind inp `elem` [Conjecture, Question] =-    do clausifyObligs theory obligs (tag inp) (split' (what inp)) inps--  clausifyObligs theory obligs s [] inps =-    do clausifyInputs theory obligs inps-  -  clausifyObligs theory obligs s (a:as) inps =-    do cs <- clausForm s (nt a)-       clausifyObligs theory (obligs `S.append` S.Unit cs) s as inps--  split' a | splitting flags = if null split_a then [true] else split_a-    where split_a = split a-  split' a                   = [a]--split :: Form -> [Form]-split p =-  case positive p of-    ForAll (Bind xs p) ->-      [ ForAll (Bind xs p') | p' <- split p ]-    -    And ps ->-      concatMap split (S.toList ps)-    -    p `Equiv` q ->-      split (nt p \/ q) ++ split (p \/ nt q)--    Or ps ->-      snd $-      maximumBy first-      [ (siz q, [ Or (S.fromList (q':qs)) | q' <- sq ])-      | (q,qs) <- select (S.toList ps)-      , let sq = split q-      ]--    _ ->-      [p]- where-  select []     = []-  select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ]-  -  first (n,x) (m,y) = n `compare` m-  -  siz (And ps)            = S.length ps-  siz (ForAll (Bind _ p)) = siz p-  siz (_ `Equiv` _)       = 2-  siz _                   = 0--{-  -    Or ps | S.size ps > 0 && n > 0 ->-      [ Or (S.fromList (p':ps')) | p' <- split p ]-     where-      pns = [(p,siz p) | p <- S.toList ps]-      ((p,n),pns') = getMax (head pns) [] (tail pns)-      ps' = [ p' | (p',_) <- pns' ]-    -  getMax pn@(p,n) pns [] = (pn,pns)-  getMax pn@(p,n) pns (qm@(q,m):qms)-    | m > n     = getMax qm (pn:pns) qms-    | otherwise = getMax pn (qm:pns) qms--}--------------------------------------------------------------------------- core clausification algorithm--clausForm :: BS.ByteString -> Form -> M [Input Clause]-clausForm s p =-  withName s $-    do miniscoped      <- miniscope . check . simplify                      . check $ p-       noEquivPs       <- removeEquiv                                       . check $ miniscoped-       noExistsPs      <- mapM removeExists                                 . check $ noEquivPs-       noExpensiveOrPs <- fmap concat . mapM removeExpensiveOr              . check $ noExistsPs-       noForAllPs      <- lift . lift . mapM uniqueNames                    . check $ noExpensiveOrPs-       let !cnf_        = S.concatMap cnf                                   . check $ noForAllPs-           !simp        = simplifyCNF . fmap S.toList                       . check $ cnf_-           cs           = S.toList . fmap clause                                    $ simp-           inps         = [ Input (BS.append s (BS.pack i)) Axiom c-                          | (c, i) <- zip cs ("":-                                        [ '_':show i | i <- [1..] ]) ]-       return $! force . check                                                      $ inps--------------------------------------------------------------------------- miniscoping-miniscope :: Form -> M Form-miniscope t@Literal{} = return t-miniscope (Not f) = fmap Not (miniscope f)-miniscope (And fs) = fmap And (S.mapM miniscope fs)-miniscope (Or fs) = fmap Or (S.mapM miniscope fs)-miniscope (Equiv f g) = liftM2 Equiv (miniscope f) (miniscope g)-miniscope (ForAll (Bind xs f)) = miniscope f >>= forAll xs-miniscope (Exists (Bind xs f)) = miniscope f >>= forAll xs . nt >>= return . nt--forAll :: NameMap Variable -> Form -> M Form-forAll xs a | Map.null xs = return a-forAll xs a =-  case positive a of-    And as ->-      fmap And (S.mapM (forAll xs) as)-    -    ForAll (Bind ys a)-      | Map.null m -> return (ForAll (Bind ys a))-      | otherwise -> fmap (forAll' ys) (forAll m a)-      where m = xs Map.\\ ys-            forAll' vs (ForAll (Bind vs' t)) = ForAll (Bind (vs `Map.union` vs') t)-            forAll' vs t = ForAll (Bind vs t)--    Or as -> forAllOr xs [ (a, free a) | a <- S.toList as ]--    _ -> return (ForAll (Bind xs a))--forAllOr :: NameMap Variable -> [(Form, NameMap Variable)] -> M Form-forAllOr xs avss = do { y <- yes; forAll xs' (y \/ no) }-  where-    v         = head (NameMap.toList xs)-    xs'       = NameMap.delete v xs-    (bs1,bs2) = partition ((v `NameMap.member`) . snd) avss-    no        = orl [ b | (b,_) <- bs2 ]-    body      = orl [ b | (b,_) <- bs1 ]-    yes       = case bs1 of-                  []      -> return (orl [])-                  [(b,_)] -> forAll (NameMap.singleton v) b-                  _       -> return (ForAll (Bind (NameMap.singleton v) body))-    orl       = foldr (\/) false--------------------------------------------------------------------------- removing equivalences---- removeEquiv p -> ps :---   POST: And ps is equivalent to p (modulo extra symbols)---   POST: ps has no Equiv and no Not-removeEquiv :: Form -> M [Form]-removeEquiv p =-  do (defs,pos,_) <- removeEquivAux False p-     return (S.toList (defs `S.append` S.Unit pos))---- removeEquivAux inEquiv p -> (defs,pos,neg) :---   PRE: inEquiv is True when we are "under" an Equiv---   POST: defs is a list of definitions, under which---         pos is equivalent to p and neg is equivalent to nt p--- (the reason why "neg" and "nt pos" can be different, is--- because we want to always code an equivalence as--- a conjunction of two disjunctions, which leads to fewer--- clauses -- the "neg" part of the result for the case Equiv--- below makes use of this)-removeEquivAux :: Bool -> Form -> M (Seq Form,Form,Form)-removeEquivAux inEquiv p =-  case simple p of-    Not p ->-      do (defs,pos,neg) <- removeEquivAux inEquiv p-         return (defs,neg,pos)-  -    And ps ->-      do dps <- sequence [ removeEquivAux inEquiv p | p <- S.toList ps ]-         let (defss,poss,negs) = unzip3 dps-         return ( S.concat defss-                , And (S.fromList poss)-                , Or  (S.fromList negs)-                )--    ForAll (Bind xs p) ->-      do (defs,pos,neg) <- removeEquivAux inEquiv p-         return ( defs-                , ForAll (Bind xs pos)-                , Exists (Bind xs neg)-                )--    p `Equiv` q ->-      do (defsp,posp,negp)    <- removeEquivAux True p-         (defsq,posq,negq)    <- removeEquivAux True q-         (defsp',posp',negp') <- makeCopyable inEquiv posp negp-         (defsq',posq',negq') <- makeCopyable inEquiv posq negq-         return ( S.concat [defsp, defsq, defsp', defsq']-                , (negp' \/ posq') /\ (posp' \/ negq')-                , (negp' \/ negq') /\ (posp' \/ posq')-                )--    Literal l ->-      do return (S.Nil,Literal l,Literal (neg l))---- makeCopyable turns an argument to an Equiv into something that we are--- willing to copy. There are two such cases: (1) when the Equiv is--- not under another Equiv (because we have to copy arguments to an Equiv--- at least once anyway), (2) if the formula is small.--- All other formulas will be made small (by means of a definition)--- before we copy them.-makeCopyable :: Bool -> Form -> Form -> M (Seq Form,Form,Form)-makeCopyable inEquiv pos neg-  | isSmall pos || not inEquiv =-    -- we skolemize here so that we reuse the skolem function-    -- (if we do this after copying, we get several skolemfunctions)-    do pos' <- removeExists pos-       neg' <- removeExists neg-       return (S.Nil,pos',neg')--  | otherwise =-    do dp <- literal "equiv" (free pos)-       return (S.fromList [Literal (Neg dp) \/ pos, Literal (Pos dp) \/ neg], Literal (Pos dp), Literal (Neg dp))- where-  -- a formula is small if it is already a literal-  isSmall (Literal _)         = True-  isSmall (Not p)             = isSmall p-  isSmall (ForAll (Bind _ p)) = isSmall p-  isSmall (Exists (Bind _ p)) = isSmall p-  isSmall _                   = False--------------------------------------------------------------------------- skolemization---- removeExists p -> p'---   PRE: p has no Equiv and no Not---   POST: p' is equivalent to p (modulo extra symbols)---   POST: p' has no Equiv, no Exists, and no Not-removeExists :: Form -> M Form-removeExists (And ps) =-  do ps <- sequence [ removeExists p | p <- S.toList ps ]-     return (And (S.fromList ps))--removeExists (Or ps) =-  do ps <- sequence [ removeExists p | p <- S.toList ps ]-     return (Or (S.fromList ps))-    -removeExists (ForAll (Bind xs p)) =-  do p' <- removeExists p-     return (ForAll (Bind xs p'))-    -removeExists t@(Exists (Bind xs p)) =-  -- skolemterms have only variables as arguments, arities are large(r)-  do ss <- sequence [ fmap (x |=>) (skolem x (free t)) | x <- NameMap.toList xs ]-     removeExists (subst (foldr (|+|) ids ss) p)-  {--  -- skolemterms can have other skolemterms as arguments, arities are small(er)-  -- disadvantage: skolemterms are very complicated and deep-  do p' <- skolemize p-     t <- skolem x (S.delete x (free p'))-     return (subst (x |=> t) p')-  -}--removeExists lit =-  do return lit---- TODO: Avoid recomputing "free" at every step, by having--- skolemize return the set of free variables as well---- TODO: Investigate skolemizing top-down instead, find the right--- optimization--------------------------------------------------------------------------- make cheap Ors--removeExpensiveOr :: Form -> M [Form]-removeExpensiveOr p =-  do (defs,p',_) <- removeExpensiveOrAux p-     return (S.toList (defs `S.append` S.Unit p'))---- cost: represents how it expensive it is to clausify a formula-type Cost = (Integer,Integer) -- (#clauses, #literals)--unitCost :: Cost-unitCost = (1,1)--andCost :: [Cost] -> Cost-andCost cs = (sum (map fst cs), sum (map snd cs))--orCost :: [Cost] -> Cost-orCost []           = (1,0)-orCost [c]          = c-orCost ((c1,l1):cs) = (c1 * c2, c1 * l2 + c2 * l1)- where-  (c2,l2) = orCost cs-  -removeExpensiveOrAux :: Form -> M (Seq Form,Form,Cost)-removeExpensiveOrAux (And ps) =-  do dcs <- sequence [ removeExpensiveOrAux p | p <- S.toList ps ]-     let (defss,ps,costs) = unzip3 dcs-     return (S.concat defss, And (S.fromList ps), andCost costs)--removeExpensiveOrAux (Or ps) =-  do dcs <- sequence [ removeExpensiveOrAux p | p <- S.toList ps ]-     let (defss,ps,costs) = unzip3 dcs-     (defs2,p,c) <- makeOr (sortBy (comparing snd) (zip ps costs))-     return (S.concat defss `S.append` defs2,p,c)--removeExpensiveOrAux (ForAll (Bind xs p)) =-  do (defs,p',cost) <- removeExpensiveOrAux p-     return (fmap (ForAll . Bind xs) defs, ForAll (Bind xs p'), cost)--removeExpensiveOrAux lit =-  do return (S.Nil, lit, unitCost)---- input is sorted; small costs first-makeOr :: [(Form,Cost)] -> M (Seq Form,Form,Cost)-makeOr [] =-  do return (S.Nil, false, orCost [])--makeOr [(f,c)] =-  do return (S.Nil,f,c)--makeOr fcs-  | null fcs2 =-    do return (S.Nil, Or (S.fromList (map fst fcs1)), orCost (map snd fcs1))--  | otherwise =-    do d <- literal "or" (free (map fst fcs2))-       (defs,p,_) <- makeOr ((Literal (Neg d),unitCost):fcs2)-       return ( defs `S.snoc` p-              , Or (S.fromList (Literal (Pos d) : map fst fcs1))-              , orCost (unitCost : map snd fcs1)-              )- where-  (fcs1,fcs2) = split [] fcs-  -  split fcs1 []                            = (fcs1,[])-  split fcs1 (fc@(_,(cc,_)):fcs) | cc <= 1 = split (fc:fcs1) fcs-  split fcs1 fcs@((_,(cc,_)):_)  | cc <= 2 = (take 2 fcs ++ fcs1, drop 2 fcs)-  split fcs1 fcs                           = (take 1 fcs ++ fcs1, drop 1 fcs)--------------------------------------------------------------------------- clausification---- cnf p = cs---   PRE: p has no Equiv, no Exists, and no Not,---        and each variable is only bound once---   POST: And (map Or cs) is equivalent to p-cnf :: Form -> Seq (Seq Literal)-cnf (ForAll (Bind _ p)) = cnf p-cnf (And ps)            = S.concatMap cnf ps-cnf (Or ps)             = cross (fmap cnf ps)-cnf (Literal x)         = S.Unit (S.Unit x)--cross :: Seq (Seq (Seq Literal)) -> Seq (Seq Literal)-cross S.Nil = S.Unit S.Nil-cross (S.Unit x) = x-cross (S.Append cs1 cs2) = liftM2 S.append (cross cs1) (cross cs2)--------------------------------------------------------------------------- simplification of CNF--simplifyCNF :: Seq [Literal] -> [[Literal]]-simplifyCNF =-  -- nub: don't generate multiple copies of identical clauses-  nub . S.concatMap (tautElim . unify [])-  where -- remove negative variable equalities X != Y by substitution-        unify xs [] = xs-        unify xs (Neg (Var v :=: t@Var{}):ys) =-          unify (subst (v |=> t) xs) (subst (v |=> t) ys)-        unify xs (l:ys) = unify (l:xs) ys-        -- simplify p | ~p or t = t to true.-        tautElim ls-          | Set.null (pos `Set.intersection` neg) && not (any tauto ls)-            -- reorder the order of the literals in the clause-            -- so that more clauses become equal;-            -- also, remove duplicate literals from the clause-            = S.Unit (map Neg (Set.toList neg) ++ map Pos (Set.toList pos))-          | otherwise = S.Nil-          where pos = Set.fromList [ l | Pos l <- ls ]-                neg = Set.fromList [ l | Neg l <- ls ]-                tauto (Pos (t :=: u)) = t == u-                tauto _ = False--------------------------------------------------------------------------- monad--type M = ReaderT Tag (StateT Int NameM)--run :: M a -> NameM a-run x = evalStateT (runReaderT x BS.empty) 0--skolemName :: Named a => String -> a -> M Name-skolemName prefix v = do-  i <- get-  put (i+1)-  s <- getName-  lift . lift . newName $ prefix ++ show i ++ concat [ "_" ++ t | t <- map BS.unpack [s, baseName v], not (null t) ]--nextSk :: M Int-nextSk = do-  i <- get-  put (i+1)-  return i--withName :: Tag -> M a -> M a-withName s m = lift (runReaderT m s)--getName :: M Tag-getName = ask--skolem :: Variable -> NameMap Variable -> M Term-skolem (v ::: t) vs =-  do n <- skolemName "sK" v-     let f = n ::: FunType (map typ args) t-     return (f :@: map Var args)- where-  args = NameMap.toList vs--literal :: String -> NameMap Variable -> M Atomic-literal w vs =-  do n <- skolemName "sP" w-     let p = n ::: FunType (map typ args) O-     return (Tru (p :@: map Var args))- where-  args = NameMap.toList vs--------------------------------------------------------------------------- the end.
− Jukebox/Form.hs 
@@ -1,716 +0,0 @@--- Formulae, inputs, terms and so on.------ "Show" instances for several of these types are found in TPTP.Print.--{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, Rank2Types, GADTs, TypeOperators, ScopedTypeVariables, BangPatterns, PatternGuards #-}-module Jukebox.Form where--import Prelude hiding (sequence, mapM)-import qualified Jukebox.Seq as S-import Jukebox.Seq(Seq)-import Data.Hashable-import qualified Jukebox.Map as Map-import Jukebox.NameMap(NameMap)-import qualified Jukebox.NameMap as NameMap-import Data.Ord-import qualified Data.ByteString.Char8 as BS-import Jukebox.Name-import Control.Monad.State.Strict hiding (sequence, mapM)-import Data.List hiding (nub)-import Jukebox.Utils-import Data.Typeable(Typeable)-import Data.Monoid-import Data.Traversable---- Set to True to switch on some sanity checks-debugging :: Bool-debugging = False--------------------------------------------------------------------------- Types--data DomainSize = Finite Int | Infinite deriving (Eq, Ord, Show, Typeable)--data Type =-    O-  | Type {-      tname :: {-# UNPACK #-} !Name,-      -- type is monotone when domain size is >= tmonotone-      tmonotone :: DomainSize,-      -- if there is a model of size >= tsize then there is a model of size tsize-      tsize :: DomainSize } deriving Typeable--data FunType = FunType { args :: [Type], res :: Type } deriving (Eq, Typeable)---- Helper function for defining (Eq, Ord, Hashable) instances-typeMaybeName :: Type -> Maybe Name-typeMaybeName O = Nothing-typeMaybeName Type{tname = t} = Just t--instance Eq Type where-  t1 == t2 = typeMaybeName t1 == typeMaybeName t2--instance Ord Type where-  compare = comparing typeMaybeName--instance Hashable Type where-  hashWithSalt s = hashWithSalt s . typeMaybeName--instance Named Type where-  name O = nameO-  name Type{tname = t} = t---- Typeclass of "things that have a type"-class Typed a where-  typ :: a -> Type--instance Typed Type where-  typ = id--instance Typed FunType where-  typ = res--instance Typed b => Typed (a ::: b) where-  typ (_ ::: t) = typ t--------------------------------------------------------------------------- Terms--type Variable = Name ::: Type-type Function = Name ::: FunType-data Term = Var Variable | Function :@: [Term] deriving (Eq, Ord)--instance Hashable Term where-  hashWithSalt s = hashWithSalt s . convert-    where convert (Var x) = Left x-          convert (f :@: ts) = Right (f, ts)--instance Named Term where-  name (Var x) = name x-  name (f :@: _) = name f--instance Typed Term where-  typ (Var x) = typ x-  typ (f :@: _) = typ f--newSymbol :: Named a => a -> b -> NameM (Name ::: b)-newSymbol x ty = fmap (::: ty) (newName x)--newFunction :: Named a => a -> [Type] -> Type -> NameM Function-newFunction x args res = newSymbol x (FunType args res)--newType :: Named a => a -> NameM Type-newType x = do-  n <- newName x-  return (Type n Infinite Infinite)--funArgs :: Function -> [Type]-funArgs (_ ::: ty) = args ty--arity :: Function -> Int-arity = length . funArgs--size :: Term -> Int-size Var{} = 1-size (f :@: xs) = 1 + sum (map size xs)--------------------------------------------------------------------------- Literals--infix 8 :=:-data Atomic = Term :=: Term | Tru Term---- Helper for (Eq Atomic, Ord Atomic, Hashable Atomic) instances-normAtomic :: Atomic -> Either (Term, Term) Term-normAtomic (t1 :=: t2) | t1 > t2 = Left (t2, t1)-                       | otherwise = Left (t1, t2)-normAtomic (Tru p) = Right p--instance Eq Atomic where-  t1 == t2 = normAtomic t1 == normAtomic t2--instance Ord Atomic where-  compare = comparing normAtomic--instance Hashable Atomic where-  hashWithSalt s = hashWithSalt s . normAtomic--data Signed a = Pos a | Neg a deriving (Show, Eq, Ord)--instance Hashable a => Hashable (Signed a) where-  hashWithSalt s = hashWithSalt s . convert-    where convert (Pos x) = Left x-          convert (Neg x) = Right x--instance Functor Signed where-  fmap f (Pos x) = Pos (f x)-  fmap f (Neg x) = Neg (f x)-type Literal = Signed Atomic--neg :: Signed a -> Signed a-neg (Pos x) = Neg x-neg (Neg x) = Pos x--the :: Signed a -> a-the (Pos x) = x-the (Neg x) = x--pos :: Signed a -> Bool-pos (Pos _) = True-pos (Neg _) = False--signForm :: Signed a -> Form -> Form-signForm (Pos _) f = f-signForm (Neg _) f = Not f--------------------------------------------------------------------------- Formulae---- Invariant: each name is bound only once on each path--- i.e. nested quantification of the same variable twice is not allowed--- Not OK: ![X]: (... ![X]: ...)--- OK:     (![X]: ...) & (![X]: ...)--- Free variables must also not be bound inside subformulae-data Form-  = Literal Literal-  | Not Form-  | And (Seq Form)-  | Or (Seq Form)-  | Equiv Form Form-  | ForAll {-# UNPACK #-} !(Bind Form)-  | Exists {-# UNPACK #-} !(Bind Form)-    -- Just exists so that parsing followed by pretty-printing is-    -- somewhat lossless; the simplify function will get rid of it-  | Connective Connective Form Form---- Miscellaneous connectives that exist in TPTP-data Connective = Implies | Follows | Xor | Nor | Nand--connective :: Connective -> Form -> Form -> Form-connective Implies t u = nt t \/ u-connective Follows t u = t \/ nt u-connective Xor t u = nt (t `Equiv` u)-connective Nor t u = nt (t \/ u)-connective Nand t u = nt (t /\ u)--data Bind a = Bind (NameMap Variable) a--true, false :: Form-true = And S.Nil-false = Or S.Nil--isTrue, isFalse :: Form -> Bool-isTrue (And S.Nil) = True-isTrue _ = False-isFalse (Or S.Nil) = True-isFalse _ = False--nt :: Form -> Form-nt (Not a) = a-nt a       = Not a--(.=>.) :: Form -> Form -> Form-(.=>.) = connective Implies--(.=.) :: Term -> Term -> Form-t .=. u | typ t == O = Literal (Pos (Tru t)) `Equiv` Literal (Pos (Tru u))-        | otherwise = Literal (Pos (t :=: u))--(/\), (\/) :: Form -> Form -> Form-And as /\ And bs = And (as `S.append` bs)-a      /\ b | isFalse a || isFalse b = false-And as /\ b      = And (b `S.cons` as)-a      /\ And bs = And (a `S.cons` bs)-a      /\ b      = And (S.Unit a `S.append` S.Unit b)--Or as \/ Or bs = Or (as `S.append` bs)-a     \/ b | isTrue a || isTrue b = true-Or as \/ b     = Or (b `S.cons` as)-a     \/ Or bs = Or (a `S.cons` bs)-a     \/ b     = Or (S.Unit a `S.append` S.Unit b)--closeForm :: Form -> Form-closeForm f | Map.null vars = f-            | otherwise = ForAll (Bind vars f)-  where vars = free f--conj, disj :: S.List f => f Form -> Form-conj = And . S.fromList-disj = Or . S.fromList---- remove Not from the root of a problem-positive :: Form -> Form-positive (Not f) = notInwards f--- Some connectives are fairly not-ish-positive (Connective c t u)         = positive (connective c t u)-positive f = f--notInwards :: Form -> Form-notInwards (And as)             = Or (fmap notInwards as)-notInwards (Or as)              = And (fmap notInwards as)-notInwards (a `Equiv` b)        = notInwards a `Equiv` b-notInwards (Not a)              = positive a-notInwards (ForAll (Bind vs a)) = Exists (Bind vs (notInwards a))-notInwards (Exists (Bind vs a)) = ForAll (Bind vs (notInwards a))-notInwards (Literal l)          = Literal (neg l)-notInwards (Connective c t u)   = notInwards (connective c t u)---- remove Exists and Or from the top level of a formula-simple :: Form -> Form-simple (Or as)              = Not (And (fmap nt as))-simple (Exists (Bind vs a)) = Not (ForAll (Bind vs (nt a)))-simple (Connective c t u)   = simple (connective c t u)-simple a                    = a---- perform some easy algebraic simplifications-simplify t@Literal{} = t-simplify (Connective c t u) = simplify (connective c t u)-simplify (Not t) = simplify (notInwards t)-simplify (And ts) = S.fold (/\) id true (fmap simplify ts)-simplify (Or ts) = S.fold (\/) id false (fmap simplify ts)-simplify (Equiv t u) = equiv (simplify t) (simplify u)-  where equiv t u | isTrue t = u-                  | isTrue u = t-                  | isFalse t = nt u-                  | isFalse u = nt t-                  | otherwise = Equiv t u-simplify (ForAll (Bind vs t)) = forAll vs (simplify t)-  where forAll vs t | Map.null vs = t-        forAll vs (ForAll (Bind vs' t)) = ForAll (Bind (Map.union vs vs') t)-        forAll vs t = ForAll (Bind vs t)-simplify (Exists (Bind vs t)) = exists vs (simplify t)-  where exists vs t | Map.null vs = t-        exists vs (Exists (Bind vs' t)) = Exists (Bind (Map.union vs vs') t)-        exists vs t = Exists (Bind vs t)--------------------------------------------------------------------------- Clauses--type CNF = Closed Obligs--data Obligs = Obligs {-  axioms :: [Input Clause],-  conjectures :: [[Input Clause]],-  satisfiable :: String,-  unsatisfiable :: String-  }--toObligs :: [Input Clause] -> [[Input Clause]] -> Obligs-toObligs axioms [] = Obligs axioms [[]] "Satisfiable" "Unsatisfiable"-toObligs axioms [conjecture] = Obligs axioms [conjecture] "CounterSatisfiable" "Theorem"-toObligs axioms conjectures = Obligs axioms conjectures "GaveUp" "Theorem"--newtype Clause = Clause (Bind [Literal])--clause :: S.List f => f (Signed Atomic) -> Clause-clause xs = Clause (bind (S.toList xs))--toForm :: Clause -> Form-toForm (Clause (Bind vs ls)) = ForAll (Bind vs (Or (S.fromList (map Literal ls))))--toLiterals :: Clause -> [Literal]-toLiterals (Clause (Bind _ ls)) = ls--------------------------------------------------------------------------- Problems--type Tag = BS.ByteString--data Kind = Axiom | Conjecture | Question deriving (Eq, Ord)--data Answer = Satisfiable | Unsatisfiable | NoAnswer NoAnswerReason-  deriving (Eq, Ord)--instance Show Answer where-  show Satisfiable = "Satisfiable"-  show Unsatisfiable = "Unsatisfiable"-  show (NoAnswer x) = show x--data NoAnswerReason = GaveUp | Timeout deriving (Eq, Ord, Show)--data Input a = Input-  { tag ::  Tag,-    kind :: Kind,-    what :: a }--type Problem a = Closed [Input a]--instance Functor Input where-  fmap f x = x { what = f (what x) }--------------------------------------------------------------------------- Symbolic stuff---- A universe of types with typecase-data TypeOf a where-  Form :: TypeOf Form-  Clause_ :: TypeOf Clause-  Term :: TypeOf Term-  Atomic :: TypeOf Atomic-  Signed :: (Symbolic a, Symbolic (Signed a)) => TypeOf (Signed a)-  Bind_ :: (Symbolic a, Symbolic (Bind a)) => TypeOf (Bind a)-  List :: (Symbolic a, Symbolic [a]) => TypeOf [a]-  Seq :: (Symbolic a, Symbolic (Seq a)) => TypeOf (Seq a)-  Input_ :: (Symbolic a, Symbolic (Input a)) => TypeOf (Input a)-  Obligs_ :: TypeOf Obligs--class Symbolic a where-  typeOf :: a -> TypeOf a--instance Symbolic Form where typeOf _ = Form-instance Symbolic Clause where typeOf _ = Clause_-instance Symbolic Term where typeOf _ = Term-instance Symbolic Atomic where typeOf _ = Atomic-instance Symbolic a => Symbolic (Signed a) where typeOf _ = Signed-instance Symbolic a => Symbolic (Bind a) where typeOf _ = Bind_-instance Symbolic a => Symbolic [a] where typeOf _ = List-instance Symbolic a => Symbolic (Seq a) where typeOf _ = Seq-instance Symbolic a => Symbolic (Input a) where typeOf _ = Input_-instance Symbolic Obligs where typeOf _ = Obligs_---- Generic representations of values.-data Rep a where-  Const :: !a -> Rep a-  Unary :: Symbolic a => (a -> b) -> a -> Rep b-  Binary :: (Symbolic a, Symbolic b) => (a -> b -> c) -> a -> b -> Rep c---- This inline declaration is crucial so that--- pattern-matching on a rep degenerates into typecase.-{-# INLINE rep #-}-rep :: Symbolic a => a -> Rep a-rep x =-  case typeOf x of-    Form -> rep' x-    Clause_ -> rep' x-    Term -> rep' x-    Atomic -> rep' x-    Signed -> rep' x-    Bind_ -> rep' x-    List -> rep' x-    Seq -> rep' x-    Input_ -> rep' x-    Obligs_ -> rep' x---- Implementation of rep for all types-class Unpack a where-  rep' :: a -> Rep a--instance Unpack Form where-  rep' (Literal l) = Unary Literal l-  rep' (Not t) = Unary Not t-  rep' (And ts) = Unary And ts-  rep' (Or ts) = Unary Or ts-  rep' (Equiv t u) = Binary Equiv t u-  rep' (ForAll b) = Unary ForAll b-  rep' (Exists b) = Unary Exists b-  rep' (Connective c t u) = Binary (Connective c) t u--instance Unpack Clause where-  rep' (Clause ls) = Unary Clause ls--instance Unpack Term where-  rep' t@Var{} = Const t-  rep' (f :@: ts) = Unary (f :@:) ts--instance Unpack Atomic where-  rep' (t :=: u) = Binary (:=:) t u-  rep' (Tru p) = Unary Tru p--instance Symbolic a => Unpack (Signed a) where-  rep' (Pos x) = Unary Pos x-  rep' (Neg x) = Unary Neg x--instance Symbolic a => Unpack (Bind a) where-  rep' (Bind vs x) = Unary (Bind vs) x--instance Symbolic a => Unpack [a] where-  rep' [] = Const []-  rep' (x:xs) = Binary (:) x xs--instance Symbolic a => Unpack (Seq a) where-  rep' S.Nil = Const S.Nil-  rep' (S.Unit x) = Unary S.Unit x-  rep' (S.Append x y) = Binary S.Append x y--instance Symbolic a => Unpack (Input a) where-  rep' (Input tag kind what) = Unary (Input tag kind) what--instance Unpack Obligs where-  rep' (Obligs ax conj s1 s2) =-    Binary (\ax' conj' -> Obligs ax' conj' s1 s2) ax conj---- Little generic strategies--{-# INLINE recursively #-}-recursively :: Symbolic a => (forall a. Symbolic a => a -> a) -> a -> a-recursively h t =-  case rep t of-    Const x -> x-    Unary f x -> f (h x)-    Binary f x y -> f (h x) (h y)--{-# INLINE recursivelyM #-}-recursivelyM :: (Monad m, Symbolic a) => (forall a. Symbolic a => a -> m a) -> a -> m a-recursivelyM h t =-  case rep t of-    Const x -> return x-    Unary f x -> liftM f (h x)-    Binary f x y -> liftM2 f (h x) (h y)--{-# INLINE collect #-}-collect :: (Symbolic a, Monoid b) => (forall a. Symbolic a => a -> b) -> a -> b-collect h t =-  case rep t of-    Const x -> mempty-    Unary f x -> h x-    Binary f x y -> h x `mappend` h y--------------------------------------------------------------------------- Substitutions--type Subst = NameMap (Name ::: Term)--ids :: Subst-ids = Map.empty--(|=>) :: Named a => a -> Term -> Subst-v |=> x = NameMap.singleton (name v ::: x)--(|+|) :: Subst -> Subst -> Subst-(|+|) = Map.union--subst :: Symbolic a => Subst -> a -> a-subst s t =-  case typeOf t of-    Term -> term t-    Bind_ -> bind t-    _ -> generic t-  where-    term (Var x)-      | Just u <- NameMap.lookup (name x) s = rhs u-    term t = generic t--    bind :: Symbolic a => Bind a -> Bind a-    bind (Bind vs t) =-      Bind vs (subst (checkBinder vs (s Map.\\ vs)) t)--    generic :: Symbolic a => a -> a-    generic t = recursively (subst s) t--------------------------------------------------------------------------- Functions operating on symbolic terms--free :: Symbolic a => a -> NameMap Variable-free t-  | Term <- typeOf t,-    Var x <- t        = var x-  | Bind_ <- typeOf t = bind t-  | otherwise         = collect free t-  where-    var :: Variable -> NameMap Variable-    var x = NameMap.singleton x--    bind :: Symbolic a => Bind a -> NameMap Variable-    bind (Bind vs t) = free t Map.\\ vs--ground :: Symbolic a => a -> Bool-ground = Map.null . free--bind :: Symbolic a => a -> Bind a-bind x = Bind (free x) x---- Helper function for collecting information from terms and binders.-termsAndBinders :: forall a b.-                   Symbolic a =>-                   (Term -> Seq b) ->-                   (forall a. Symbolic a => Bind a -> Seq b) ->-                   a -> Seq b-termsAndBinders term bind = aux where-  aux :: Symbolic c => c -> Seq b-  aux t =-    collect aux t `S.append`-    case typeOf t of-      Term -> term t-      Bind_ -> bind t-      _ -> S.Nil--names :: Symbolic a => a -> [Name]-names = nub . termsAndBinders term bind where-  term t = return (name t) `mappend` return (name (typ t))--  bind :: Symbolic a => Bind a -> Seq Name-  bind (Bind vs _) = S.fromList (map name (NameMap.toList vs))--types :: Symbolic a => a -> [Type]-types = nub . termsAndBinders term bind where-  term t = return (typ t)--  bind :: Symbolic a => Bind a -> Seq Type-  bind (Bind vs _) = S.fromList (map typ (NameMap.toList vs))--types' :: Symbolic a => a -> [Type]-types' = filter (/= O) . types--terms :: Symbolic a => a -> [Term]-terms = nub . termsAndBinders term mempty where-  term t = return t--vars :: Symbolic a => a -> [Variable]-vars = nub . termsAndBinders term bind where-  term (Var x) = return x-  term _ = mempty--  bind :: Symbolic a => Bind a -> Seq Variable-  bind (Bind vs _) = S.fromList (NameMap.toList vs)--functions :: Symbolic a => a -> [Function]-functions = nub . termsAndBinders term mempty where-  term (f :@: _) = return f-  term _ = mempty--isFof :: Symbolic a => a -> Bool-isFof f = length (types' f) <= 1--uniqueNames :: Symbolic a => a -> NameM a-uniqueNames t = evalStateT (aux Map.empty t) (free t)-  where aux :: Symbolic a => Subst -> a -> StateT (NameMap Variable) NameM a-        aux s t =-          case typeOf t of-            Term -> term s t-            Bind_ -> bind s t-            _ -> generic s t--        term :: Subst -> Term -> StateT (NameMap Variable) NameM Term-        term s t@(Var x) = do-          case NameMap.lookup (name x) s of-            Nothing -> return t-            Just (_ ::: u) -> return u-        term s t = generic s t--        bind :: Symbolic a => Subst -> Bind a -> StateT (NameMap Variable) NameM (Bind a)-        bind s (Bind vs x) = do-          used <- get-          let (stale, fresh) = partition (`NameMap.member` used) (NameMap.toList vs)-          stale' <- sequence [ lift (newSymbol x t) | x ::: t <- stale ]-          put (used `Map.union` NameMap.fromList fresh `Map.union` NameMap.fromList stale')-          case stale of-            [] -> fmap (Bind vs) (aux s x)-            _ ->-              do-                let s' = NameMap.fromList [name x ::: Var y | (x, y) <- stale `zip` stale'] `Map.union` s-                    vs' = NameMap.fromList (stale' ++ fresh)-                fmap (Bind vs') (aux s' x)--        generic :: Symbolic a => Subst -> a -> StateT (NameMap Variable) NameM a-        generic s t = recursivelyM (aux s) t---- Force a value.-force :: Symbolic a => a -> a-force x = rnf x `seq` x-  where rnf :: Symbolic a => a -> ()-        rnf x =-          case rep x of-            Const !_ -> ()-            Unary _ x -> rnf x-            Binary _ x y -> rnf x `seq` rnf y---- Check that there aren't two nested binders binding the same variable-check :: Symbolic a => a -> a-check x | not debugging = x-        | check' (free x) x = x-        | otherwise = error "Form.check: invariant broken"-  where check' :: Symbolic a => NameMap Variable -> a -> Bool-        check' vars t =-          case typeOf t of-            Term -> term vars t-            Bind_ -> bind vars t-            _ -> generic vars t--        term :: NameMap Variable -> Term -> Bool-        term vars (Var x) = x `NameMap.member` vars-        term vars t = generic vars t--        bind :: Symbolic a => NameMap Variable -> Bind a -> Bool-        bind vars (Bind vs t) =-          Map.null (vs `Map.intersection` vars) &&-          check' (vs `Map.union` vars) t--        generic :: Symbolic a => NameMap Variable -> a -> Bool-        generic vars = getAll . collect (All . generic vars)---- Check that a binder doesn't capture variables from a substitution.-checkBinder :: NameMap Variable -> Subst -> Subst-checkBinder vs s | not debugging = s-                 | Map.null (free [ t | _ ::: t <- NameMap.toList s ] `Map.intersection` vs) = s-                 | otherwise = error "Form.checkBinder: capturing substitution"---- Reestablish sharing in a formula.-type ShareState = (NameMap Type, NameMap Variable, NameMap Function)--share :: Symbolic a => a -> a-share x = evalState (shareM x) initial-  where initial :: ShareState-        initial = (Map.empty, Map.empty, Map.empty)--        shareM :: Symbolic a => a -> State ShareState a-        shareM t =-          case typeOf t of-            Term -> term t-            Bind_ -> bind t-            _ -> recursivelyM shareM t--        bind :: Symbolic a => Bind a -> State ShareState (Bind a)-        bind (Bind vs x) =-          liftM2 Bind (mapM var vs) (shareM x)--        term :: Term -> State ShareState Term-        term (Var x) = fmap Var (var x)-        term (f :@: ts) = liftM2 (:@:) (fun f) (mapM term ts)--        fun :: Function -> State ShareState Function-        fun (f ::: FunType args res) = do-          args' <- mapM type_ args-          res' <- type_ res-          memo funAccessor (f ::: FunType args' res')--        var :: Variable -> State ShareState Variable-        var (x ::: ty) = fmap (x :::) (type_ ty) >>= memo varAccessor--        type_ :: Type -> State ShareState Type-        type_ = memo typeAccessor--        typeAccessor = (\(x, y, z) -> x, \x (_, y, z) -> (x, y, z))-        varAccessor = (\(x, y, z) -> y, \y (x, _, z) -> (x, y, z))-        funAccessor = (\(x, y, z) -> z, \z (x, y, _) -> (x, y, z))--        memo :: Named a =>-                (ShareState -> NameMap a,-                 NameMap a -> ShareState -> ShareState) ->-                a -> State ShareState a-        memo (get_, put_) x = do-          m <- gets get_-          case NameMap.lookup (name x) m of-            Nothing -> do-              modify (put_ (NameMap.insert x m))-              return x-            Just y ->-              return y---- Apply a function to each type, while preserving sharing.-mapType :: Symbolic a => (Type -> Type) -> a -> a-mapType f = share . mapType'-  where mapType' :: Symbolic a => a -> a-        mapType' t =-          case typeOf t of-            Term -> term t-            Bind_ -> bind t-            _ -> recursively mapType' t--        bind :: Symbolic a => Bind a -> Bind a-        bind (Bind vs t) = Bind (fmap var vs) (mapType' t)--        term (f :@: ts) = fun f :@: map term ts-        term (Var x) = Var (var x)--        var (x ::: ty) = x ::: f ty-        fun (x ::: FunType args res) = x ::: FunType (map f args) (f res)
− Jukebox/GuessModel.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE GADTs, PatternGuards #-}-module Jukebox.GuessModel where--import Control.Monad-import qualified Data.ByteString.Char8 as BS-import Jukebox.Name-import Jukebox.Form-import Jukebox.Clausify hiding (cnf)-import Jukebox.TPTP.Print-import Jukebox.TPTP.ParseSnippet-import Jukebox.Utils--data Universe = Peano | Trees--universe :: Universe -> Type -> NameM ([Function], [Form])-universe Peano = peano-universe Trees = trees--peano i = do-  zero <- newFunction "zero" [] i-  succ <- newFunction "succ" [i] i-  pred <- newFunction "pred" [i] i-  let types = [("$i", i)]-      funs = [("zero", zero),-              ("succ", succ),-              ("pred", pred)]-  -  prelude <- mapM (cnf types funs) [-    "zero != succ(X)",-    "pred(succ(X)) = X"-    ]-  return ([zero, succ], prelude)--trees i = do-  nil <- newFunction "nil" [] i-  bin <- newFunction "bin" [i, i] i-  left <- newFunction "left" [i] i-  right <- newFunction "right" [i] i-  let types = [("$i", i)]-      funs = [("nil", nil),-              ("bin", bin),-              ("left", left),-              ("right", right)]-  -  prelude <- mapM (cnf types funs) [-    "nil != bin(X,Y)",-    "left(bin(X,Y)) = X",-    "right(bin(X,Y)) = Y"-    ]-  return ([nil, bin], prelude)--guessModel :: [String] -> Universe -> Problem Form -> Problem Form-guessModel expansive univ prob = close prob $ \forms -> do-  let i = ind forms-  answerType <- newType "answer"-  answer <- newFunction "$answer" [answerType] O-  let withExpansive f func = f func (BS.unpack (base (name func)) `elem` expansive) answer-  (constructors, prelude) <- universe univ i-  program <- fmap concat (mapM (withExpansive (function constructors)) (functions forms))-  return (map (Input (BS.pack "adt") Axiom) prelude ++-          map (Input (BS.pack "program") Axiom) program ++-          forms)--ind :: Symbolic a => a -> Type-ind x =-  case types' x of-    [ty] -> ty-    [] -> Type nameI Infinite Infinite-    _ -> error "GuessModel: can't deal with many-typed problems"--function :: [Function] -> Function -> Bool -> Function -> NameM [Form]-function constructors f expansive answerP = fmap concat $ do-  argss <- cases constructors (funArgs f)-  forM argss $ \args -> do-    fname <- newFunction ("exhausted_" ++ BS.unpack (base (name f)) ++ "_case")-               [] (head (funArgs answerP))-    let answer = Literal (Pos (Tru (answerP :@: [fname :@: []])))-    let theRhss = rhss constructors args f expansive answer-    alts <- forM theRhss $ \rhs -> do-      pred <- newFunction (concat (lines (prettyFormula rhs))) [] O-      return (Literal (Pos (Tru (pred :@: []))))-    return $-      disj alts:-      [ closeForm (Connective Implies alt rhs)-      | (alt, rhs) <- zip alts theRhss ]--rhss :: [Function] -> [Term] -> Function -> Bool -> Form -> [Form]-rhss constructors args f expansive answer =-  case typ f of-    O ->-      Literal (Pos (Tru (f :@: args))):-      Literal (Neg (Tru (f :@: args))):-      map its (map (f :@:) (recursive args))-    _ | expansive -> map its (usort (unconditional ++ constructor))-      | otherwise -> map its (usort unconditional) ++ [answer]-  where recursive [] = []-        recursive (a:as) = reduce a ++ map (a:) (recursive as)-          where reduce (f :@: xs) = [ x:as' | x <- xs, as' <- as:recursive as ]-                reduce _ = []-        constructor = [ c :@: xs-                      | c <- constructors,-                        xs <- sequence (replicate (arity c) unconditional) ]-        -        subterm = terms args-        its t = f :@: args .=. t-        unconditional = map (f :@:) (recursive args) ++ subterm--cases :: [Function] -> [Type] -> NameM [[Term]]-cases constructors [] = return [[]]-cases constructors (ty:tys) = do-  ts <- cases1 constructors ty-  tss <- cases constructors tys-  return (liftM2 (:) ts tss)--cases1 :: [Function] -> Type -> NameM [Term]-cases1 constructors ty = do-  let maxArity = maximum (map arity constructors)-      varNames = take maxArity (cycle ["X", "Y", "Z"])-  vars <- mapM (flip newSymbol ty) varNames-  return [ c :@: take (arity c) (map Var vars)-         | c <- constructors ]
− Jukebox/HighSat.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}-module Jukebox.HighSat where--import MiniSat hiding (neg)-import qualified MiniSat-import qualified Jukebox.Seq as Seq-import Jukebox.Seq(Seq, List)-import Jukebox.Form(Signed(..), neg)-import qualified Jukebox.Map as Map-import Jukebox.Map(Map)-import Control.Monad.State.Strict-import Control.Monad.Reader-import Control.Monad.Trans-import Data.Hashable-import Data.Traversable hiding (mapM, sequence)-import Control.Applicative-import Data.Maybe-import Data.List(partition)-import Control.Applicative--newtype Sat1 a b = Sat1 { runSat1_ :: ReaderT Solver (ReaderT (Watch a) (StateT (Map a Lit) IO)) b } deriving (Functor, Applicative, Monad, MonadIO)-newtype Sat a b c = Sat { runSat_ :: ReaderT (Watch a) (StateT (Map b (SatState a)) IO) c } deriving (Functor, Applicative, Monad, MonadIO)-data SatState a = SatState Solver (Map a Lit)-type Watch a = a -> Sat1 a ()--data Form a-  = Lit (Signed a)-  | And (Seq (Form a))-  | Or (Seq (Form a))--nt :: Form a -> Form a-nt (Lit x) = Lit (neg x)-nt (And xs) = Or (fmap nt xs)-nt (Or xs) = And (fmap nt xs)--conj, disj :: List f => f (Form a) -> Form a-conj = And . Seq.fromList-disj = Or . Seq.fromList--true, false :: Form a-true = And Seq.Nil-false = Or Seq.Nil--unique :: List f => f (Form a) -> Form a-unique = u . Seq.toList-  where u [x] = true-        u (x:xs) = conj [disj [nt x, conj (map nt xs)],-                         u xs]--runSat :: (Hashable b, Ord b) => Watch a -> [b] -> Sat a b c -> IO c-runSat w idxs x = go idxs Map.empty-  where go [] m = evalStateT (runReaderT (runSat_ x) w) m-        go (idx:idxs) m =-          withNewSolver $ \s -> go idxs (Map.insert idx (SatState s Map.empty) m)--runSat1 :: (Ord a, Hashable a) => Watch a -> Sat1 a b -> IO b-runSat1 w x = runSat w [()] (atIndex () x)--atIndex :: (Ord a, Hashable a, Ord b, Hashable b) => b -> Sat1 a c -> Sat a b c-atIndex !idx m = do-  watch <- Sat ask-  SatState s ls <- Sat (gets (Map.findWithDefault (error "withSolver: index not found") idx))-  (x, ls') <- liftIO (runStateT (runReaderT (runReaderT (runSat1_ m) s) watch) ls)-  Sat (modify (Map.insert idx (SatState s ls')))-  return x--solve :: (Ord a, Hashable a) => [Signed a] -> Sat1 a Bool-solve xs = do-  s <- Sat1 ask-  ls <- mapM lit xs-  liftIO (MiniSat.solve s ls)--model :: (Ord a, Hashable a) => Sat1 a (a -> Bool)-model = do-  s <- Sat1 ask-  m <- Sat1 (lift get)-  vals <- liftIO (traverse (MiniSat.modelValue s) m)-  return (\v -> fromMaybe False (Map.findWithDefault Nothing v vals))--modelValue :: (Ord a, Hashable a) => a -> Sat1 a Bool-modelValue x = do-  s <- Sat1 ask-  l <- var x-  Just b <- liftIO (MiniSat.modelValue s l)-  return b--addForm :: (Ord a, Hashable a) => Form a -> Sat1 a ()-addForm f = do-  s <- Sat1 ask-  cs <- flatten f-  liftIO (Seq.mapM (MiniSat.addClause s . Seq.toList) cs)-  return ()--flatten :: (Ord a, Hashable a) => Form a -> Sat1 a (Seq (Seq Lit))-flatten (Lit l) = fmap (Seq.Unit . Seq.Unit) (lit l)-flatten (And fs) = fmap Seq.concat (Seq.mapM flatten fs)-flatten (Or fs) = fmap (fmap Seq.concat . Seq.sequence) (Seq.mapM flatten fs)--lit :: (Ord a, Hashable a) => Signed a -> Sat1 a Lit-lit (Pos x) = var x-lit (Neg x) = liftM MiniSat.neg (var x)--var :: (Ord a, Hashable a) => a -> Sat1 a Lit-var x = do-  s <- Sat1 ask-  m <- Sat1 get-  case Map.lookup x m of-    Nothing -> do-      l <- liftIO (MiniSat.newLit s)-      Sat1 (put (Map.insert x l m))-      w <- Sat1 (lift ask)-      w x-      return l-    Just l -> return l
− Jukebox/InferTypes.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE TypeOperators, GADTs #-}-module Jukebox.InferTypes where--import Control.Monad-import Jukebox.Form-import Jukebox.Name-import qualified Jukebox.NameMap as NameMap-import Jukebox.NameMap(NameMap)-import Jukebox.UnionFind hiding (rep)--type Function' = Name ::: ([Type'], Type')-type Variable' = Name ::: Type'-type Type' = Name ::: Type--inferTypes :: [Input Clause] -> NameM ([Input Clause], Type -> Type)-inferTypes prob = do-  funMap <--    fmap NameMap.fromList . sequence $-      [ do res <- newName (typ f)-           args <- mapM newName (funArgs f)-           return (name f :::-                   (zipWith (:::) args (funArgs f),-                    res ::: typ f))-      | f <- functions prob ]-  varMap <--    fmap NameMap.fromList . sequence $-      [ do ty <- newName (typ v)-           return (name v ::: (ty ::: typ v))-      | v <- vars prob ]-  -  let tyMap = NameMap.fromList $-              concat [ res:args | _ ::: (args, res) <- NameMap.toList funMap ] ++-              [ ty | _ ::: ty <- NameMap.toList varMap ]-  -  let (prob', rep) = solve funMap varMap prob-      rep' ty = rhs (NameMap.lookup_ (rep (name ty)) tyMap)-  -  return (prob', rep')--solve :: NameMap Function' -> NameMap Variable' ->-         [Input Clause] -> ([Input Clause], Name -> Name)-solve funMap varMap prob = (prob', rep)-  where prob' = share (aux prob)-        aux :: Symbolic a => a -> a-        aux t =-          case typeOf t of-            Bind_ -> bind t-            Term -> term t-            _ -> recursively aux t--        bind :: Symbolic a => Bind a -> Bind a-        bind (Bind vs t) = Bind (fmap var vs) (aux t)--        term (f :@: ts) = fun f :@: map term ts-        term (Var x) = Var (var x)--        fun (f ::: _) =-          let (args, res) = rhs (NameMap.lookup_ f funMap)-          in f ::: FunType (map type_ args) (type_ res)--        var (x ::: _) = x ::: type_ (rhs (NameMap.lookup_ x varMap))--        type_ (name ::: _) -          | name == nameO = O-          | otherwise = Type (rep name) Infinite Infinite--        rep = evalUF initial $ do-          generate funMap varMap prob-          reps--generate :: NameMap Function' -> NameMap Variable' -> [Input Clause] -> UF Name ()-generate funMap varMap cs = mapM_ (mapM_ atomic) lss-  where lss = map (map the . toLiterals . what) cs-        atomic (Tru p) = void (term p)-        atomic (t :=: u) = do { t' <- term t; u' <- term u; t' =:= u'; return () }-        term (Var x) = return y-          where _ ::: (y ::: _) = NameMap.lookup_ x varMap-        term (f :@: xs) = do-          ys <- mapM term xs-          let _ ::: (zs, r) = NameMap.lookup_ f funMap-          zipWithM_ (=:=) ys (map lhs zs)-          return (lhs r)
− Jukebox/Map.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-module Jukebox.Map where--import qualified Data.HashMap.Lazy as H--type Map a b = H.HashMap a b--fromList = H.fromList-toList = H.toList-insertWith = H.insertWith-empty = H.empty-findWithDefault = H.lookupDefault-lookup = H.lookup-insert = H.insert-delete = H.delete-elems = H.elems-union = H.union-intersection = H.intersection-null = H.null-m ! x = H.lookupDefault (error "Map.!: key not found") x m--member x m =-  case H.lookup x m of-    Nothing -> False-    Just{} -> True--m1 \\ m2 =-  H.foldrWithKey (\k v m -> H.delete k m) m1 m2
− Jukebox/Monotonox/Monotonicity.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Jukebox.Monotonox.Monotonicity where--import Prelude hiding (lookup)-import Jukebox.Name-import Jukebox.Form hiding (Form, clause, true, false, conj, disj)-import Jukebox.HighSat-import Jukebox.NameMap as NameMap-import Jukebox.Utils-import Data.Hashable-import Control.Monad--data Extension = TrueExtend | FalseExtend | CopyExtend deriving Show--data Var = FalseExtended Function | TrueExtended Function deriving (Eq, Ord)--instance Hashable Var where-  hashWithSalt s = hashWithSalt s . convert-    where convert (FalseExtended x) = Left x-          convert (TrueExtended x) = Right x--annotateMonotonicity :: Problem Clause -> IO (Problem Clause)-annotateMonotonicity prob = do-  m <- monotone (map what (open prob))-  let f O = O-      f ty =-        case lookup (name ty) m of-          Nothing -> ty-          Just{} -> ty { tmonotone = Finite 0 }-  return (fmap (mapType f) prob)--monotone :: [Clause] -> IO (NameMap (Type ::: Maybe (NameMap (Function ::: Extension))))-monotone cs = runSat watch tys $ do-  let fs = functions cs-  mapM_ (clause . toLiterals) cs-  fmap NameMap.fromList . forM tys $ \ty -> atIndex ty $ do-    r <- solve []-    case r of-      False -> return (ty ::: Nothing)-      True -> do-        m <- model-        return (ty ::: Just (fromModel fs ty m))-  where watch (FalseExtended f) =-          addForm (disj [Lit (Neg (FalseExtended f)),-                         Lit (Neg (TrueExtended f))])-        watch _ = return ()-        tys = types' cs--fromModel :: [Function] -> Type -> (Var -> Bool) -> NameMap (Function ::: Extension)-fromModel fs ty m = NameMap.fromList [ f ::: extension f m | f <- fs, typ f == O, ty `elem` args (rhs f) ]--extension :: Function -> (Var -> Bool) -> Extension-extension f m =-  case (m (FalseExtended f), m (TrueExtended f)) of-    (False, False) -> CopyExtend-    (True, False) -> FalseExtend-    (False, True) -> TrueExtend--clause :: [Literal] -> Sat Var Type ()-clause ls = mapM_ (literal ls) ls--literal :: [Literal] -> Literal -> Sat Var Type ()-literal ls (Pos (t :=: u)) = atIndex (typ t) $ do-  addForm (safe ls t)-  addForm (safe ls u)-literal ls (Neg (_ :=: _)) = return ()-literal ls (Pos (Tru (p :@: ts))) =-  forM_ ts $ \t -> atIndex (typ t) $ addForm (disj [safe ls t, Lit (Neg (FalseExtended p))])-literal ls (Neg (Tru (p :@: ts))) =-  forM_ ts $ \t -> atIndex (typ t) $ addForm (disj [safe ls t, Lit (Neg (TrueExtended p))])--safe :: [Literal] -> Term -> Form Var-safe ls (Var x) = disj [ guards l x | l <- ls ]-safe _ _ = true--guards :: Literal -> Variable -> Form Var-guards (Neg (Var _ :=: Var _)) _ = error "Monotonicity.guards: found a variable inequality X!=Y after clausification"-guards (Neg (Var x :=: _)) y | x == y = true-guards (Neg (_ :=: Var x)) y | x == y = true-guards (Pos (Tru (p :@: ts))) x | Var x `elem` ts = Lit (Pos (TrueExtended p))-guards (Neg (Tru (p :@: ts))) x | Var x `elem` ts = Lit (Pos (FalseExtended p))-guards _ _ = false
− Jukebox/Monotonox/ToFOF.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE GADTs, PatternGuards #-}-module Jukebox.Monotonox.ToFOF where--import Jukebox.Clausify(split, removeEquiv, run, withName)-import Jukebox.Name-import qualified Jukebox.NameMap as NameMap-import Jukebox.Form-import Jukebox.Options-import qualified Data.ByteString.Char8 as BS-import Control.Monad hiding (guard)-import Data.Monoid--data Scheme = Scheme {-  makeFunction :: Type -> NameM Function,-  scheme1 :: (Type -> Bool) -> (Type -> Function) -> Scheme1-  }--data Scheme1 = Scheme1 {-  forAll :: Bind Form -> Form,-  exists :: Bind Form -> Form,-  equals :: Term -> Term -> Form,-  funcAxiom :: Function -> NameM Form,-  typeAxiom :: Type -> NameM Form-  }--guard :: Scheme1 -> (Type -> Bool) -> Input Form -> Input Form-guard scheme mono (Input t k f) = Input t k (aux (pos k) f)-  where aux pos (ForAll (Bind vs f))-          | pos = forAll scheme (Bind vs (aux pos f))-          | otherwise = Not (exists scheme (Bind vs (Not (aux pos f))))-        aux pos (Exists (Bind vs f))-          | pos = exists scheme (Bind vs (aux pos f))-          | otherwise = Not (forAll scheme (Bind vs (Not (aux pos f))))-        aux pos (Literal (Pos (t :=: u)))-          | not (mono (typ t)) = equals scheme t u-        aux pos (Literal (Neg (t :=: u)))-          | not (mono (typ t)) = Not (equals scheme t u)-        aux pos l@Literal{} = l-        aux pos (Not f) = Not (aux (not pos) f)-        aux pos (And fs) = And (fmap (aux pos) fs)-        aux pos (Or fs) = Or (fmap (aux pos) fs)-        aux pos (Equiv _ _) = error "ToFOF.guard: equiv should have been eliminated"-        aux pos (Connective _ _ _) = error "ToFOF.guard: connective should have been eliminated"-        pos Axiom = True-        pos Conjecture = False--translate, translate1 :: Scheme -> (Type -> Bool) -> Problem Form -> Problem Form-translate1 scheme mono f = close f $ \inps -> do-  let tys = types inps-      funcs = functions inps-      -- Hardly any use adding guards if there's only one type.-      mono' | length tys == 1 = const True-            | otherwise = mono-  typeFuncs <- mapM (makeFunction scheme) tys-  let typeMap = NameMap.fromList (zipWith (:::) tys typeFuncs)-      lookupType ty =-        case NameMap.lookup (name ty) typeMap of-          Just (_ ::: f) -> f-          Nothing -> error "ToFOF.translate: type not found"-      scheme1' = scheme1 scheme mono' lookupType-  funcAxioms <- mapM (funcAxiom scheme1') funcs-  typeAxioms <- mapM (typeAxiom scheme1') tys-  let axioms =-        map (simplify . ForAll . bind) . split . simplify . foldr (/\) true $-          funcAxioms ++ typeAxioms-  return $-    [ Input (BS.pack ("types" ++ show i)) Axiom axiom | (axiom, i) <- zip axioms [1..] ] ++-    map (guard scheme1' mono') inps--translate scheme mono f =-  let f' =-        close f $ \inps -> do-          forM inps $ \(Input tag kind f) -> do-            let prepare f = fmap (foldr (/\) true) (run (withName tag (removeEquiv (simplify f))))-            fmap (Input tag kind) $-              case kind of-                Axiom -> prepare f-                Conjecture -> fmap notInwards (prepare (nt f))-      typeI = Type nameI (Finite 0) Infinite-  in close (translate1 scheme mono f') (return . mapType (const typeI))---- Typing functions.--tagsFlags :: OptionParser Bool-tagsFlags =-  bool "more-axioms"-    ["Add extra typing axioms for function arguments,",-     "when using typing tags.",-     "These are unnecessary for completeness but may help (or hinder!) the prover."]--tags :: Bool -> Scheme-tags moreAxioms = Scheme-  { makeFunction = \ty ->-      newFunction (BS.append (BS.pack "to_") (baseName ty)) [ty] ty,-    scheme1 = tags1 moreAxioms }--tags1 :: Bool -> (Type -> Bool) -> (Type -> Function) -> Scheme1-tags1 moreAxioms mono fs = Scheme1-  { forAll = ForAll,-    exists = \(Bind vs f) ->-       let bound = foldr (/\) true (map guard (NameMap.toList vs))-           guard v | mono (typ v) = true-                   | otherwise = Literal (Pos (fs (typ v) :@: [Var v] :=: Var v))-       in Exists (Bind vs (simplify bound /\ f)),-    equals =-      \t u ->-        let protect t@Var{} = fs (typ t) :@: [t]-            protect t = t-        in Literal (Pos (protect t :=: protect u)),-    funcAxiom = tagsAxiom moreAxioms mono fs,-    typeAxiom = \ty -> if moreAxioms then tagsAxiom False mono fs (fs ty) else tagsExists mono ty (fs ty) }--tagsAxiom :: Bool -> (Type -> Bool) -> (Type -> Function) -> Function -> NameM Form-tagsAxiom moreAxioms mono fs f@(_ ::: FunType args res) = do-  vs <- forM args $ \ty ->-    fmap Var (newSymbol "X" ty)-  let t = f :@: vs-      at n f xs = take n xs ++ [f (xs !! n)] ++ drop (n+1) xs-      tag t = fs (typ t) :@: [t]-      equate (ty, t') | mono ty = true-                      | otherwise = t `eq` t'-      t `eq` u | typ t == O = Literal (Pos (Tru t)) `Equiv` Literal (Pos (Tru u))-               | otherwise = Literal (Pos (t :=: u))-      ts = (typ t, tag t):-           [ (typ (vs !! n), f :@: at n tag vs)-           | moreAxioms,-             n <- [0..length vs-1] ]-  return (foldr (/\) true (map equate ts))--tagsExists :: (Type -> Bool) -> Type -> Function -> NameM Form-tagsExists mono ty f-  | mono ty = return true-  | otherwise = do-      v <- fmap Var (newSymbol "X" ty)-      return (Exists (bind (Literal (Pos (f :@: [v] :=: v)))))---- Typing predicates.--guards :: Scheme-guards = Scheme-  { makeFunction = \ty ->-      newFunction (BS.append (BS.pack "is_") (baseName ty)) [ty] O,-    scheme1 = guards1 }--guards1 :: (Type -> Bool) -> (Type -> Function) -> Scheme1-guards1 mono ps = Scheme1-  { forAll = \(Bind vs f) ->-       let bound = foldr (/\) true (map guard (NameMap.toList vs))-           guard v | mono (typ v) = true-                   | not (naked True v f) = true-                   | otherwise = Literal (Pos (Tru (ps (typ v) :@: [Var v])))-       in ForAll (Bind vs (simplify (Not bound) \/ f)),-    exists = \(Bind vs f) ->-       let bound = foldr (/\) true (map guard (NameMap.toList vs))-           guard v | mono (typ v) = true---                   | not (naked True v f) = true-                   | otherwise = Literal (Pos (Tru (ps (typ v) :@: [Var v])))-       in Exists (Bind vs (simplify bound /\ f)),-    equals = \t u -> Literal (Pos (t :=: u)),-    funcAxiom = guardsAxiom mono ps,-    typeAxiom = guardsTypeAxiom mono ps }--naked :: Symbolic a => Bool -> Variable -> a -> Bool-naked pos v f-  | Form <- typeOf f,-    Not f' <- f = naked (not pos) v f'-  | Signed <- typeOf f,-    Pos f' <- f = naked pos v f'-  | Signed <- typeOf f,-    Neg f' <- f = naked (not pos) v f'-  | Atomic <- typeOf f,-    t :=: u <- f,-    pos = t == Var v || u == Var v-  | Bind_ <- typeOf f,-    Bind vs f' <- f = not (NameMap.member v vs) && naked pos v f'-  | otherwise = getAny (collect (Any . naked pos v) f)--guardsAxiom :: (Type -> Bool) -> (Type -> Function) -> Function -> NameM Form-guardsAxiom mono ps f@(_ ::: FunType args res)-  | mono res = return true-  | otherwise = do-    vs <- forM args $ \ty ->-      fmap Var (newSymbol "X" ty)-    return (Literal (Pos (Tru (ps res :@: [f :@: vs]))))--guardsTypeAxiom :: (Type -> Bool) -> (Type -> Function) -> Type -> NameM Form-guardsTypeAxiom mono ps ty-  | mono ty = return true-  | otherwise = do-    v <- fmap Var (newSymbol "X" ty)-    return (Exists (bind (Literal (Pos (Tru (ps ty :@: [v]))))))
− Jukebox/Name.hs 
@@ -1,153 +0,0 @@-{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving, FlexibleInstances, DeriveDataTypeable #-}-module Jukebox.Name(-  Name, uniqueId, base,-  stringBaseName,-  unsafeMakeName,-  (:::)(..), lhs, rhs,-  Named(..),-  Closed, close, close_, closedIO, open, closed0, stdNames, nameO, nameI, NameM, newName,-  unsafeClose, maxIndex, supply,-  uniquify) where--import qualified Data.ByteString.Char8 as BS-import Data.Hashable-import qualified Jukebox.Map as Map-import Jukebox.Utils-import Data.List-import Data.Ord-import Data.Int-import Data.Typeable-import Control.Monad.State.Strict-import Control.Applicative--data Name =-  Name {-    uniqueId :: {-# UNPACK #-} !Int64,-    base :: BS.ByteString } deriving Typeable--unsafeMakeName = Name--instance Eq Name where-  x == y = uniqueId x == uniqueId y--instance Ord Name where-  compare = comparing uniqueId--instance Hashable Name where-  hashWithSalt s = hashWithSalt s . uniqueId--instance Show Name where-  show Name { uniqueId = uniqueId, base = base } =-    BS.unpack base ++ show uniqueId--class Named a where-  name :: a -> Name-  baseName :: a -> BS.ByteString-  baseName = base . name--stringBaseName :: Named a => a -> String-stringBaseName = BS.unpack . baseName--instance Named BS.ByteString where-  name = error "Name.name: used a ByteString as a name"-  baseName = id--instance Named [Char] where-  name = error "Name.name: used a String as a name"-  baseName = BS.pack--instance Named Name where-  name = id--data a ::: b = !a ::: !b deriving (Show, Typeable)--lhs :: (a ::: b) -> a-lhs (x ::: _) = x--rhs :: (a ::: b) -> b-rhs (_ ::: y) = y--instance Named a => Eq (a ::: b) where s == t = name s == name t-instance Named a => Ord (a ::: b) where compare = comparing name-instance Named a => Hashable (a ::: b) where hashWithSalt s = hashWithSalt s . name--instance Named a => Named (a ::: b) where-  name (a ::: b) = name a--newtype NameM a =-  NameM { unNameM :: State Int64 a }-    deriving (Functor, Applicative, Monad)--newName :: Named a => a -> NameM Name-newName x = NameM $ do-  idx <- get-  let idx'= idx+1-  when (idx' < 0) $ error "Name.newName: too many names"-  put $! idx'-  return $! Name idx' (baseName x)--data Closed a =-  Closed {-    maxIndex :: {-# UNPACK #-} !Int64,-    open :: !a } deriving Typeable--unsafeClose = Closed--instance Functor Closed where-  fmap f (Closed m x) = Closed m (f x)--closed0 :: Closed ()-nameO, nameI :: Name--closed0 = close_ stdNames (return ())-[nameO, nameI] = open stdNames--stdNames :: Closed [Name]-stdNames = close (Closed 0 ["$o", "$i"]) (mapM newName)--close :: Closed a -> (a -> NameM b) -> Closed b-close Closed{ maxIndex = maxIndex, open = open } f =-  let (open', maxIndex') = runState (unNameM (f open)) maxIndex-  in Closed{ maxIndex = maxIndex', open = open' }--close_ :: Closed a -> NameM b -> Closed b-close_ x m = close x (const m)--closedIO :: Closed (IO a) -> IO (Closed a)-closedIO Closed { maxIndex = maxIndex, open = open } = do-  open' <- open-  return Closed { maxIndex = maxIndex, open = open' }--supply :: (Closed () -> Closed a) -> NameM a-supply f = NameM $ do-  idx <- get-  let res = f (Closed idx ())-  put (maxIndex res)-  return (open res)--uniquify :: [Name] -> (Name -> BS.ByteString)-uniquify xs = f-  -- Note to self: nameO should always be mapped to "$o".-  -- Therefore we make sure that smaller names have priority-  -- over bigger names here.-  where-    baseMap =-      -- Assign numbers to each baseName-      fmap (\xs -> Map.fromList (zip (usort xs) [0 :: Int ..])) .-      -- Partition by baseName-      foldl' (\m x -> Map.insertWith (++) (base x) [x] m) Map.empty $-      xs-    f x = combine (base x) b-      where-        b = Map.findWithDefault (error $ "Name.uniquify: name " ++ show x ++ " not found") x-            (Map.findWithDefault (error $ "Name.uniquify: name " ++ show x ++ " not found") (baseName x) baseMap)-    combine s 0 = s-    combine s n = disambiguate (BS.append s (BS.pack (show n)))-    disambiguate s-      | not (Map.member s baseMap) = s-      | otherwise =-        -- Odd situation: we have e.g. a name with baseName "f1",-        -- and two names with baseName "f", which would normally-        -- become "f" and "f1", but the "f1" conflicts.-        -- Try appending some suffix.-        disambiguate (BS.snoc s '_')
− Jukebox/NameMap.hs 
@@ -1,46 +0,0 @@-module Jukebox.NameMap(NameMap, lookup, lookup_, insert, member, delete, (!), fromList, toList, singleton) where--import Prelude hiding (lookup)-import Jukebox.Name-import Jukebox.Map(Map)-import qualified Jukebox.Map as Map-import Data.Int-import qualified Jukebox.Seq as S--type NameMap a = Map Int64 a--lookup :: Name -> NameMap a -> Maybe a-lookup x m = Map.lookup (uniqueId x) m--lookup_ :: Named a => a -> NameMap b -> b-lookup_ x m =-  case lookup (name x) m of-    Nothing -> error "NameMap.lookup_: key not found"-    Just y -> y--insert :: Named a => a -> NameMap a -> NameMap a-insert x m = Map.insert (uniqueId (name x)) x m--member :: Named a => a -> NameMap a -> Bool-member x m = keyMember (name x) m--keyMember :: Name -> NameMap a -> Bool-keyMember x m = Map.member (uniqueId x) m--delete :: Named a => a -> NameMap a -> NameMap a-delete x m = deleteKey (name x) m--deleteKey :: Name -> NameMap a -> NameMap a-deleteKey x m = Map.delete (uniqueId x) m--(!) :: NameMap a -> Name -> a-m ! x = m Map.! uniqueId (name x)--fromList :: (S.List f, Named a) => f a -> NameMap a-fromList xs = Map.fromList [ (uniqueId (name x), x) | x <- S.toList xs ]--toList :: NameMap a -> [a]-toList = Map.elems--singleton :: Named a => a -> NameMap a-singleton x = insert x Map.empty
− Jukebox/Options.hs 
@@ -1,358 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Jukebox.Options where--import Control.Arrow((***))-import Control.Applicative-import Control.Monad(mplus)-import Data.Char-import Data.List-import Data.Monoid-import System.Environment-import System.Exit-import System.IO--------------------------------------------------------------------------- A parser of some kind annotated with a help text of some kind-data Annotated d p a = Annotated-  { descr :: d,-    parser :: p a }--instance Functor p => Functor (Annotated d p) where-  fmap f (Annotated d x) = Annotated d (fmap f x)--instance (Monoid d, Applicative p) => Applicative (Annotated d p) where-  pure = Annotated mempty . pure-  Annotated d f <*> Annotated d' x =-    Annotated (d `mappend` d') (f <*> x)--instance (Monoid d, Monoid (p a)) => Monoid (Annotated d p a) where-  mempty = Annotated mempty mempty-  Annotated d p `mappend` Annotated d' p' =-    Annotated (d `mappend` d') (p `mappend` p')--------------------------------------------------------------------------- Parsing of single arguments (e.g. integers)--- and single flags (e.g. --verbosity 3).--type ArgParser = Annotated ArgDesc SeqParser-type ArgDesc = String -- description, e.g. "<number>"---- Called SeqParser because <*> is sequential composition.-data SeqParser a = SeqParser-  { args :: Int, -- How many arguments will be consumed-    consume :: [String] -> Either Error a }--instance Functor SeqParser where-  fmap f (SeqParser a c) = SeqParser a (fmap f . c)--instance Applicative SeqParser where-  pure = SeqParser 0 . const . pure-  SeqParser a c <*> SeqParser a' c' = SeqParser (a + a') f-    where f xs = c xs <*> c' (drop a xs)--arg :: ArgDesc -> String -> (String -> Maybe a) -> ArgParser a-arg desc err f = Annotated desc (SeqParser 1 c)-  where c [] = Left (Mistake err)-        c (x:_) | "--" `isPrefixOf` x = Left (Mistake err)-        c (x:_) =-          case f x of-            Nothing -> Left (Mistake err)-            Just ok -> Right ok--argNum :: (Read a, Num a) => ArgParser a-argNum = arg "<num>" "expected a number" f-  where f x =-          case reads x of-            [(y, "")] -> Just y-            _ -> Nothing--argFile :: ArgParser FilePath-argFile = arg "<file>" "expected a file" Just--argFiles :: ArgParser [FilePath]-argFiles = arg "<files>" "expected a list of files" $ \x ->-  Just $ elts $ x ++ ","-  where-    elts [] = []-    elts s  = w:elts r-      where-        w = takeWhile (/= ',') s-        r = tail (dropWhile (/= ',') s)--argName :: ArgParser FilePath-argName = arg "<name>" "expected a name" Just--argNums :: ArgParser [Int]-argNums = arg "<nums>" "expected a number list" $ \x ->-  nums . groupBy (\x y -> isDigit x == isDigit y) $ x ++ ","-  where-    nums []                = Just []-    nums (n:",":ns)        = (read n :) `fmap` nums ns-    nums (n:"..":m:",":ns) = ([read n .. read m] ++) `fmap` nums ns-    nums _                 = Nothing--argOption :: [String] -> ArgParser String-argOption as = arg ("<" ++ concat (intersperse " | " as) ++ ">") "expected an argument" elts-  where-    elts x | x `elem` as = Just x-           | otherwise   = Nothing--argList :: [String] -> ArgParser [String]-argList as = arg ("<" ++ concat (intersperse " | " as) ++ ">*") "expected an argument" $ \x ->-  elts $ x ++ ","-  where-    elts []              = Just []-    elts s | w `elem` as = (w:) `fmap` elts r-      where-        w = takeWhile (/= ',') s-        r = tail (dropWhile (/= ',') s)-    -    elts _ = Nothing---- A parser that always fails but produces an error message (useful for --help etc.)-argUsage :: ExitCode -> [String] -> ArgParser a-argUsage code err = Annotated [] (SeqParser 0 (const (Left (Usage code err))))--------------------------------------------------------------------------- Parsing of whole command lines.--type OptionParser = Annotated [Flag] ParParser---- Called ParParser because <*> is parallel composition.--- In other words, in f <*> x, f and x both see the whole command line.--- We want this when parsing command lines because--- it doesn't matter what order we write the options in.-data ParParser a = ParParser-  { val :: IO a, -- impure so we can put system information in our options records-    peek :: [String] -> ParseResult a }--data ParseResult a-    -- Yes n x: consumed n arguments, continue parsing with x-  = Yes Int (ParParser a)-    -- No x: didn't understand this flag, continue parsing with x-  | No (ParParser a)-    -- Error-  | Error Error--data Error =-    Mistake String-  | Usage ExitCode [String]--instance Functor ParParser where-  fmap f x = pure f <*> x--instance Applicative ParParser where-  pure x = ParParser (return x) (const (pure x))-  ParParser v p <*> ParParser v' p' =-    ParParser (v <*> v') (\xs -> p xs <*> p' xs)--instance Functor ParseResult where-  fmap f x = pure f <*> x--instance Applicative ParseResult where-  pure = No . pure-  Yes n r <*> Yes n' r'-    | n == n' = Yes n (r <*> r')-    | otherwise = error "Options.ParseResult: inconsistent number of arguments"-  Error s <*> _ = Error s-  _ <*> Error s = Error s-  Yes n r <*> No x = Yes n (r <*> x)-  No x <*> Yes n r = Yes n (x <*> r)-  No f <*> No x = No (f <*> x)--runPar :: ParParser a -> [String] -> Either Error (IO a)-runPar p [] = Right (val p)-runPar p xs@(x:_) =-  case peek p xs of-    Yes n p' -> runPar p' (drop n xs)-    No _ -> Left (Mistake ("Didn't recognise option " ++ x))-    Error err -> Left err--awaitP :: (String -> Bool) -> a -> (String -> [String] -> ParseResult a) -> ParParser a-awaitP p def par = ParParser (return def) f-  where f (x:xs) | p x =-          case par x xs of-            Yes n r -> Yes (n+1) r-            No _ ->-              error "Options.await: got No"-            Error err -> Error err-        f _ = No (awaitP p def par)--await :: String -> a -> ([String] -> ParseResult a) -> ParParser a-await flag def f = awaitP (\x -> "--" ++ flag == x) def (const f)--data Flag = Flag-  { flagName :: String,-    flagGroup :: String,-    flagHelp :: [String],-    flagArgs :: String } deriving (Eq, Show)---- From a flag name and and argument parser, produce an OptionParser.-flag :: String -> [String] -> a -> ArgParser a -> OptionParser a-flag name help def (Annotated desc (SeqParser args f)) =-  Annotated [desc'] (await name def g)-  where desc' = Flag name "Common options" help desc-        g xs =-          case f xs of-            Left (Mistake err) -> Error (Mistake ("Error in option --" ++ name ++ ": " ++ err))-            Left (Usage code err) -> Error (Usage code err)-            Right y -> Yes args (pure y <* noFlag)-        -- Give an error if the flag is repeated.-        noFlag =-          await name ()-            (const (Error (Mistake ("Option --" ++ name ++ " occurred twice"))))--manyFlags :: String -> [String] -> ArgParser a -> OptionParser [a]-manyFlags name help (Annotated desc (SeqParser args f)) =-  fmap reverse (Annotated [desc'] (go []))-  where desc' = Flag name "Common options" help desc-        go xs = await name xs (g xs)-        g xs ys =-          case f ys of-            Left (Mistake err) -> Error (Mistake ("Error in option --" ++ name ++ ": " ++ err))-            Left (Usage code err) -> Error (Usage code err)-            Right x -> Yes args (go (x:xs))---- Read filenames from the command line.-filenames :: OptionParser [String]-filenames = Annotated [] (from [])-  where from xs = awaitP p xs (f xs)-        p x = not ("--" `isPrefixOf` x)-        f xs y ys = Yes 0 (from (xs ++ [y]))---- Take a value from the environment.-io :: IO a -> OptionParser a-io m = Annotated [] p-  where p = ParParser m (const (No p))---- A boolean flag.-bool :: String -> [String] -> OptionParser Bool-bool name help = flag name help False (pure True)--inGroup :: String -> OptionParser a -> OptionParser a-inGroup x (Annotated fls f) = Annotated [fl{ flagGroup = x } | fl <- fls] f--------------------------------------------------------------------------- Selecting a particular tool.--type ToolParser = Annotated [Tool] PrefixParser-data Tool = Tool-  { toolProgName :: String,-    toolName :: String,-    toolVersion :: String,-    toolHelp :: String }--newtype PrefixParser a = PrefixParser (String -> Maybe (Tool, ParParser a))--instance Functor PrefixParser where-  fmap f (PrefixParser g) = PrefixParser (fmap (id *** fmap f) . g)--instance Monoid (PrefixParser a) where-  mempty = PrefixParser (const Nothing)-  PrefixParser f `mappend` PrefixParser g =-    PrefixParser (\xs -> f xs `mplus` g xs)--runPref :: PrefixParser a -> [String] -> Either Error (IO a)-runPref _ [] = Left (Mistake "Expected a tool name")-runPref (PrefixParser f) (x:xs) =-  case f x of-    Nothing -> Left (Mistake ("No such tool " ++ x))-    Just (t, p) ->-      case runPar p xs of-        Left (Mistake x) -> Left (Usage (ExitFailure 1) (argError t x))-        Left (Usage code x) -> Left (Usage code x)-        Right x -> Right x--tool :: Tool -> OptionParser a -> ToolParser a-tool t p =-  Annotated [t] (PrefixParser f)-  where f x | x == toolProgName t = Just (t, parser p')-        f _ = Nothing-        p' = p <* versionParser <* helpParser-        helpParser = flag "help" ["Show this help text."] () (argUsage ExitSuccess (help t p'))-        versionParser = flag "version" ["Print the version number."] () (argUsage ExitSuccess [greeting t])---- Use the program name as a tool name if possible.-getEffectiveArgs :: ToolParser a -> IO [String]-getEffectiveArgs (Annotated tools _) = do-  progName <--    case tools of-      [tool] -> return (toolProgName tool)-      _ -> getProgName-  args <- getArgs-  if progName `elem` map toolProgName tools-    then return (progName:args)-    else return args--parseCommandLine :: Tool -> ToolParser a -> IO a-parseCommandLine t p = do-  let p' =-        case p of-          Annotated [_] _ -> p-          _ -> versionTool t `mappend` helpTool t p `mappend` p-  args <- getEffectiveArgs p'-  case runPref (parser p') args of-    Left (Mistake err) -> printHelp (ExitFailure 1) (argError t err)-    Left (Usage code err) -> printHelp code err-    Right x -> x--------------------------------------------------------------------------- Help screens.--printHelp :: ExitCode -> [String] -> IO a-printHelp code xs = do-  mapM_ (hPutStrLn stderr ) xs-  exitWith code--argError :: Tool -> String -> [String]-argError t err = [-  greeting t,-  err ++ ". Try --help."-  ]--usageTool :: Tool -> String -> [String] -> String -> ToolParser a-usageTool t0 flag msg bit = tool (Tool flag' flag' flag' "0") p-  where p = Annotated [] (ParParser (printHelp ExitSuccess msg)-                                    (const (Error (Usage (ExitFailure 1) msg'))))-        flag' = "--" ++ flag-        msg' = [-          greeting t0,-          "Didn't expect any arguments after " ++ flag' ++ ".",-          "Try " ++ toolProgName t0 ++ " <toolname> " ++ flag' ++ " if you want " ++ bit ++ " a particular tool."-          ]--versionTool :: Tool -> ToolParser a-versionTool t0 = usageTool t0 "version" [greeting t0] "the version of"--helpTool :: Tool -> ToolParser a -> ToolParser a-helpTool t0 p = usageTool t0 "help" help "help for"-  where help = concat [-          [greeting t0],-          usage t0 "<toolname> ",-          ["<toolname> can be any of the following:"],-          concat [ justify (toolProgName t) [toolHelp t] | t <- descr p ],-          ["", "Use " ++ toolProgName t0 ++ " <toolname> --help for help on a particular tool."]-          ]--help :: Tool -> OptionParser a -> [String]-help t p = concat [-  [greeting t],-  usage t "",-  ["<option> can be any of the following:"],-  concat [ justify ("--" ++ flagName f ++ " " ++ flagArgs f) (flagHelp f) | f <- nub (descr p) ]-  ]--greeting :: Tool -> String-greeting t = toolName t ++ ", version " ++ toolVersion t ++ "."--usage :: Tool -> String -> [String]-usage t opts = [-  "Usage: " ++ toolProgName t ++ " " ++ opts ++ "<option>* <file>*",-  toolHelp t ++ ".",-  "",-  "<file> should be in TPTP format.",-  ""-  ]--justify :: String -> [String] -> [String]-justify name help = ["", "  " ++ name] ++ map ("    " ++) help
− Jukebox/ProgressBar.hs 
@@ -1,67 +0,0 @@-module Jukebox.ProgressBar(ProgressBar(..), tickOnRead, withProgressBar) where--import System.IO-import Data.IORef-import Data.Word-import qualified Data.ByteString.Lazy as BSL---import Data.ByteString.Lazy.Progress-import Control.Exception-import Control.Monad-import Prelude hiding (last)--data ProgressBar = ProgressBar { -  tick :: IO (),-  enter :: String -> IO (),-  leave :: IO ()-  }--data State = State {-  position :: Int,-  enabled :: Bool,-  level :: Int,-  last :: Last-  }-             --- What happened last.-data Last = Tick | Enter | Leave--tickOnRead :: ProgressBar -> BSL.ByteString -> IO BSL.ByteString-tickOnRead p s = do-  let chunkSize = 1000000 :: Word64-  nextRef <- newIORef chunkSize-  let f _ index = do-        next <- readIORef nextRef-        when (next <= index) $ do-          tick p-          writeIORef nextRef (next + chunkSize)-  -- trackProgress f s-  return s--withProgressBar :: (ProgressBar -> IO a) -> IO a-withProgressBar f = do-  state <- newIORef State { position = 0, enabled = True, level = 0, last = Enter }-  let spinny 0 = ".-\08"-      spinny 1 = "\\\08"-      spinny 2 = "|\08"-      spinny 3 = "/\08"-      put s = hPutStr stderr s >> hFlush stderr-      tick = do-        s <- readIORef state-        pos <--          case last s of-            Tick -> return (position s)-            Enter -> return 0-            Leave -> put " " >> return 0-        put (spinny pos)-        writeIORef state s{ position = (pos+1) `mod` 4, last = Tick }-      enter msg = do-        s <- readIORef state-        when (level s /= 0) (put " (")-        put (msg ++ "...")-        writeIORef state s{ last = Enter, level = level s + 1 }-      leave = do-        s <- readIORef state-        when (level s /= 1) (put ")")-        writeIORef state s{last = Leave, level = level s - 1 }-  f ProgressBar { tick = tick, enter = enter, leave = leave }-    `finally` put " \n"
− Jukebox/Provers/E.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE GADTs #-}-module Jukebox.Provers.E where--import Jukebox.Form hiding (tag, Or)-import Jukebox.Name-import Jukebox.Options-import Control.Applicative hiding (Const)-import Control.Monad-import Jukebox.Utils-import Jukebox.TPTP.Parsec-import Jukebox.TPTP.ClauseParser hiding (newFunction, Term)-import Jukebox.TPTP.Print-import Jukebox.TPTP.Lexer hiding (Normal, keyword, Axiom, name, Var)-import Text.PrettyPrint.HughesPJ hiding (parens)-import Data.Maybe-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Jukebox.Seq as S-import qualified Jukebox.Map as Map-import Jukebox.Map(Map)-import Data.Hashable-import System.Exit--data EFlags = EFlags {-  eprover :: String,-  timeout :: Maybe Int,-  memory :: Maybe Int-  }--eflags =-  inGroup "E prover options" $-  EFlags <$>-    flag "eprover"-      ["Path to the E theorem prover.",-       "Default: eprover"]-      "eprover"-      argFile <*>-    flag "timeout"-      ["Timeout for E, in seconds.",-       "Default: (off)"]-      Nothing-      (fmap Just argNum) <*>-    flag "memory"-      ["Memory limit for E, in megabytes.",-       "Default: (off)"]-      Nothing-      (fmap Just argNum)---- Work around bug in E answer coding.-mangleAnswer :: Symbolic a => a -> NameM a-mangleAnswer t =-  case typeOf t of-    Term -> term t-    _ -> recursivelyM mangleAnswer t-  where term (f :@: [t]) | stringBaseName f == "$answer" = do-          wrap <- newFunction "answer" [typ t] (head (funArgs f))-          return (f :@: [wrap :@: [t]])-        term t = recursivelyM mangleAnswer t--runE :: (Pretty a, Symbolic a) => EFlags -> Problem a -> IO (Either Answer [Term])-runE flags prob-  | not (isFof (open prob)) = error "runE: E doesn't support many-typed problems"-  | otherwise = do-    (code, str) <- popen (eprover flags) eflags-                   (BS.pack (render (prettyProblem "fof" Normal (close prob mangleAnswer))))-    --case code of-    --  ExitFailure code -> error $ "runE: E failed with exit code " ++ show code ++ ":\n" ++ BS.unpack str-    return (extractAnswer (open prob) (BS.unpack str))-  where eflags = [ "--soft-cpu-limit=" ++ show n | Just n <- [timeout flags] ] ++-                 ["--memory-limit=" ++ show n | Just n <- [memory flags] ] ++-                 ["--tstp-in", "--tstp-out", "-tAuto", "-xAuto"] ++-                 ["-l", "0"]--extractAnswer :: Symbolic a => a -> String -> Either Answer [Term]-extractAnswer prob str = fromMaybe (Left status) (fmap Right answer)-  where env = uniquify (S.unique (names prob))-        varMap = Map.fromList [(env (name x), x) | x <- vars prob]-        funMap = Map.fromList [(env (name x), x) | x <- functions prob]-        result = lines str-        status = head $-          [Satisfiable | "# SZS status Satisfiable" <- result] ++-          [Satisfiable | "# SZS status CounterSatisfiable" <- result] ++-          [Unsatisfiable | "# SZS status Unsatisfiable" <- result] ++-          [Unsatisfiable | "# SZS status Theorem" <- result] ++-          [NoAnswer Timeout | "# SZS status ResourceOut" <- result] ++-          [NoAnswer Timeout | "# SZS status Timeout" <- result] ++-          [NoAnswer Timeout | "# SZS status MemyOut" <- result] ++-          [NoAnswer GaveUp]-        answer = listToMaybe $-          [ parse xs-          | line <- result-          , let prefix = "# SZS answers Tuple ["-                suffix = "|_]"-                (prefix', mid) = splitAt (length prefix) line-                (xs, suffix') = splitAt (length mid - length suffix) mid-          , prefix == prefix'-          , suffix == suffix' ]-        parse xs =-          let toks = scan (BSL.pack xs)-          in case run_ parser (UserState initialState toks) of-            Ok _ ts -> ts-            _ -> error "runE: couldn't parse result from E"-        parser =-          parens (bracks term `sepBy1` punct Or)-          <|> fmap (:[]) (bracks term)-        term =-          fmap (Var . lookup varMap) variable <|>-          liftM2 (:@:) (fmap (lookup funMap) atom) terms-        terms =-          bracks (term `sepBy1` punct Comma)-          <|> return []-        lookup :: (Ord a, Hashable a) => Map BS.ByteString a -> BS.ByteString -> a-        lookup m x = Map.findWithDefault (error "runE: result from E mentions free names") x m
− Jukebox/Provers/SPASS.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE GADTs #-}-module Jukebox.Provers.SPASS where--import Jukebox.Form hiding (tag, Or)-import Jukebox.Name-import Jukebox.Options-import Control.Applicative hiding (Const)-import Control.Monad-import Jukebox.Utils-import Jukebox.TPTP.Parsec-import Jukebox.TPTP.ClauseParser hiding (newFunction, Term)-import Jukebox.TPTP.Print-import Jukebox.TPTP.Lexer hiding (Normal, keyword, Axiom, name, Var)-import Text.PrettyPrint.HughesPJ hiding (parens)-import Data.Maybe-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Jukebox.Seq as S-import qualified Jukebox.Map as Map-import Jukebox.Map(Map)-import Data.Hashable-import System.Exit--data SPASSFlags =-  SPASSFlags {-    spass   :: String,-    timeout :: Maybe Int,-    sos     :: Bool }--spassFlags =-  inGroup "SPASS prover options" $-  SPASSFlags <$>-    flag "spass"-      ["Path to SPASS.",-       "Default: SPASS"]-      "SPASS"-      argFile <*>-    flag "timeout"-      ["Timeout in seconds.",-       "Default: (none)"]-      Nothing-      (fmap Just argNum) <*>-    flag "sos"-      ["Use set-of-support strategy.",-       "Default: false"]-      False-      (pure True)--runSPASS :: (Pretty a, Symbolic a) => SPASSFlags -> Problem a -> IO Answer-runSPASS flags prob-  | not (isFof (open prob)) = error "runSPASS: SPASS doesn't support many-typed problems"-  | otherwise = do-    (code, str) <- popen (spass flags) spassFlags-                   (BS.pack (render (prettyProblem "cnf" Normal prob)))-    return (extractAnswer (BS.unpack str))-  where-    spassFlags =-      ["-TimeLimit=" ++ show n | Just n <- [timeout flags] ] ++-      ["-SOS" | sos flags] ++-      ["-TPTP", "-Stdin"]--extractAnswer :: String -> Answer-extractAnswer result =-  head $-    [ Unsatisfiable    | "SPASS beiseite: Proof found." <- lines result ] ++-    [ Satisfiable      | "SPASS beiseite: Completion found." <- lines result ] ++-    [ NoAnswer Timeout ]
− Jukebox/Sat.hs 
@@ -1,70 +0,0 @@-module Jukebox.Sat-  ( Solver-  , newSolver-  , deleteSolver-  , Lit, neg-  , false, true-  -  , SatSolver(..)-  , newLit-  , addClause-  , solve-  , conflict-  , modelValue-  , value-  )- where------------------------------------------------------------------------------------import MiniSat-  ( Solver-  , deleteSolver-  , Lit(..)-  , neg-  )--import qualified MiniSat as M------------------------------------------------------------------------------------false, true :: Lit-true  = MkLit 0-false = neg true--newSolver :: IO Solver-newSolver =-  do s <- M.newSolver-     x <- M.newLit s-     if x == false || x == true-       then do M.addClause s [true]-               return s-       else do error "failed to initialize false and true!"------------------------------------------------------------------------------------class SatSolver s where-  getSolver :: s -> Solver--instance SatSolver Solver where-  getSolver s = s--newLit :: SatSolver s => s -> IO Lit-newLit s = M.newLit (getSolver s)--addClause :: SatSolver s => s -> [Lit] -> IO ()-addClause s xs = M.addClause (getSolver s) xs >> return ()--solve :: SatSolver s => s -> [Lit] -> IO Bool-solve s xs = M.solve (getSolver s) xs--conflict :: SatSolver s => s -> IO [Lit]-conflict s = M.conflict (getSolver s)--modelValue :: SatSolver s => s -> Lit -> IO (Maybe Bool)-modelValue s x = M.modelValue (getSolver s) x--value :: SatSolver s => s -> Lit -> IO (Maybe Bool)-value s x = M.value (getSolver s) x----------------------------------------------------------------------------------
− Jukebox/Sat3.hs 
@@ -1,47 +0,0 @@-module Jukebox.Sat3 where--import Jukebox.Sat------------------------------------------------------------------------------------data Lit3 = Lit3{ isFalse :: Lit, isTrue :: Lit }--false3, true3, bottom3 :: Lit3-false3  = Lit3 true false-true3   = neg3 false3-bottom3 = Lit3 false false--neg3 :: Lit3 -> Lit3-neg3 (Lit3 f t) = Lit3 t f--newLit3 :: SatSolver s => s -> IO Lit3-newLit3 s =-  do a <- newLit s-     b <- newLit s-     addClause s [neg a, neg b]-     return (Lit3 a b)--newLit2 :: SatSolver s => s -> IO Lit3-newLit2 s =-  do a <- newLit s-     return (Lit3 a (neg a))------------------------------------------------------------------------------------modelValue3 :: SatSolver s => s -> Lit3 -> IO (Maybe Bool)-modelValue3 s = val3 (modelValue s)--value3 :: SatSolver s => s -> Lit3 -> IO (Maybe Bool)-value3 s = val3 (value s)--val3 :: (Lit -> IO (Maybe Bool)) -> Lit3 -> IO (Maybe Bool)-val3 get (Lit3 f t) =-  do mf <- get f-     case mf of-       Just True -> do return (Just False)-       _         -> do mt <- get t-                       case mt of-                         Just True -> return (Just True)-                         _         -> return Nothing----------------------------------------------------------------------------------
− Jukebox/SatEq.hs 
@@ -1,85 +0,0 @@-module Jukebox.SatEq where--import Jukebox.Sat-import Jukebox.Sat3-import Jukebox.SatMin--import Data.IORef-import Data.Map as M------------------------------------------------------------------------------------data SolverEq =-  SolverEq-  { satSolver :: Solver-  , counter   :: IORef Int-  , table     :: IORef (Map (Elt,Elt) Lit3)-  , model     :: IORef (Maybe (Map Elt Elt))-  }--newSolverEq :: Solver -> IO SolverEq-newSolverEq s =-  do ctr <- newIORef 0-     tab <- newIORef M.empty-     mod <- newIORef Nothing-     return SolverEq-       { satSolver = s-       , counter   = ctr-       , table     = tab-       , model     = mod-       }--instance SatSolver SolverEq where-  getSolver = satSolver--class SatSolver s => EqSolver s where-  getSolverEq :: s -> SolverEq--instance EqSolver SolverEq where-  getSolverEq s = s------------------------------------------------------------------------------------newtype Elt = Elt Int-  deriving ( Eq, Ord )--instance Show Elt where-  show (Elt k) = "#" ++ show k--newElt :: EqSolver s => s -> IO Elt-newElt s =-  do k <- readIORef (counter (getSolverEq s))-     writeIORef (counter (getSolverEq s)) $! k+1-     return (Elt k)--equal :: EqSolver s => s -> Elt -> Elt -> IO Lit3-equal s x y =-  case x `compare` y of-    GT -> equal s y x-    EQ -> return true3-    LT -> do tab <- readIORef (table (getSolverEq s))-             case M.lookup (x,y) tab of-               Just q ->-                 do return q-       -               Nothing ->-                 do q <- newLit3 s-                    writeIORef (table (getSolverEq s)) (M.insert (x,y) q tab)-                    return q------------------------------------------------------------------------------------solveEq :: EqSolver s => s -> [Lit] -> IO Bool-solveEq = undefined------------------------------------------------------------------------------------modelRep :: EqSolver s => s -> Elt -> IO (Maybe Elt)-modelRep s x =-  do mmod <- readIORef (model (getSolverEq s))-     return $-       case mmod of-         Just mp -> M.lookup x mp-         Nothing -> Nothing----------------------------------------------------------------------------------
− Jukebox/SatMin.hs 
@@ -1,29 +0,0 @@-module Jukebox.SatMin where--import Jukebox.Sat--solveLocalMin :: SatSolver s => s -> [Lit] -> [Lit] -> IO Bool-solveLocalMin s as ms =-  do b <- solve s as-     if b then do l <- newLit s -- used as a local assumption for this minimization-                  localMin s as l ms-                  addClause s [neg l]-                  return True-          else do return False--localMin :: SatSolver s => s -> [Lit] -> Lit -> [Lit] -> IO ()-localMin s as l ms =-  do -- find out the current values of the m's-     bs <- sequence [ modelValue s m | m <- ms ]-  -     -- assert that all false m's should stay false-     sequence_ [ addClause s [neg l, neg m] | (m,b) <- ms `zip` bs, b /= Just True ]-     -     -- assert that at least one true m should become false also-     let ms1 = [ m | (m,Just True)  <- ms `zip` bs ]-     addClause s (neg l : [ neg m | m <- ms1 ])-     -     -- is there still a solution?-     b <- solve s (l:as)-     if b then localMin s as l ms1-          else return ()
− Jukebox/Seq.hs 
@@ -1,109 +0,0 @@--- Strict lists with efficient append.-module Jukebox.Seq where--import Prelude hiding (concat, concatMap, length, mapM, mapM_)-import Control.Monad hiding (mapM, mapM_)-import Data.Hashable-import qualified Data.HashSet as Set-import Data.Monoid-import Control.Applicative--data Seq a = Append (Seq a) (Seq a) | Unit a | Nil--class List f where-  fromList :: f a -> Seq a-  toList :: f a -> [a]--instance List [] where-  fromList = foldr cons Nil-  toList = id--instance List Seq where-  fromList = id-  toList x = go [x]-    -- (if you squint here you can see difference lists...)-    where go (Nil:left) = go left-          go (Unit x:left) = x:go left-          go (Append x y:left) = go (x:y:left)-          go [] = []--appendA :: Seq a -> Seq a -> Seq a-appendA Nil xs = xs-appendA xs Nil = xs-appendA xs ys = Append xs ys--instance Show a => Show (Seq a) where-  show = show . toList--cons :: a -> Seq a -> Seq a-cons x xs = Unit x `appendA` xs--snoc :: Seq a -> a -> Seq a-snoc xs x = xs `appendA` Unit x--append :: (List f, List g) => f a -> g a -> Seq a-append xs ys = fromList xs `appendA` fromList ys--instance Functor Seq where-  fmap f (Append x y) = Append (fmap f x) (fmap f y)-  fmap f (Unit x) = Unit (f x)-  fmap f Nil = Nil--instance Applicative Seq where-  pure = return-  (<*>) = liftM2 ($)--instance Monad Seq where-  return = Unit-  x >>= f = concatMapA f x-  fail _ = Nil--instance Alternative Seq where-  empty = mzero-  (<|>) = mplus--instance MonadPlus Seq where-  mzero = Nil-  mplus = append--instance Monoid (Seq a) where-  mempty = Nil-  mappend = append--concat :: (List f, List g) => f (g a) -> Seq a-concat = concatMap id--concatMap :: (List f, List g) => (a -> g b) -> f a -> Seq b-concatMap f xs = concatMapA (fromList . f) (fromList xs)--concatMapA :: (a -> Seq b) -> Seq a -> Seq b-concatMapA f = aux-  where aux (Append x y) = aux x `appendA` aux y-        aux (Unit x) = f x-        aux Nil = Nil--fold :: (b -> b -> b) -> (a -> b) -> b -> Seq a -> b-fold app u n (Append x y) = app (fold app u n x) (fold app u n y)-fold app u n (Unit x) = u x-fold app u n Nil = n--unique :: (Ord a, Hashable a, List f) => f a -> [a]-unique = Set.toList . Set.fromList . toList . fromList--length :: Seq a -> Int-length Nil = 0-length (Unit _) = 1-length (Append x y) = length x + length y--mapM :: Monad m => (a -> m b) -> Seq a -> m (Seq b)-mapM f Nil = return Nil-mapM f (Unit x) = liftM Unit (f x)-mapM f (Append x y) = liftM2 Append (mapM f x) (mapM f y)--mapM_ :: Monad m => (a -> m ()) -> Seq a -> m ()-mapM_ f Nil = return ()-mapM_ f (Unit x) = f x-mapM_ f (Append x y) = mapM_ f x >> mapM_ f y--sequence :: Monad m => Seq (m a) -> m (Seq a)-sequence = mapM id
− Jukebox/TPTP/ClauseParser.hs 
@@ -1,481 +0,0 @@--- Parse and typecheck TPTP clauses, stopping at include-clauses.--{-# LANGUAGE BangPatterns, MultiParamTypeClasses, ImplicitParams, FlexibleInstances, TypeOperators, TypeFamilies #-}-module Jukebox.TPTP.ClauseParser where--import Jukebox.TPTP.Parsec-import Control.Applicative-import Control.Monad-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.ByteString.Char8 as BS-import qualified Jukebox.Map as Map-import Jukebox.Map(Map)-import qualified Jukebox.Seq as S-import Jukebox.Seq(Seq)-import Data.List-import Jukebox.TPTP.Print-import Jukebox.Name hiding (name)-import qualified Jukebox.NameMap as NameMap--import Jukebox.TPTP.Lexer hiding-  (Pos, Error, Include, Var, Type, Not, ForAll,-   Exists, And, Or, Type, Apply, Implies, Follows, Xor, Nand, Nor,-   keyword, defined, kind)-import qualified Jukebox.TPTP.Lexer as L-import qualified Jukebox.Form as Form-import Jukebox.Form hiding (tag, kind, Axiom, Conjecture, Question, newFunction, TypeOf(..))-import qualified Jukebox.Name as Name---- The parser monad--data ParseState =-  MkState ![Input Form]                           -- problem being constructed, inputs are in reverse order-          !(Map BS.ByteString Type)               -- types-          !(Map BS.ByteString (Name ::: FunType)) -- functions-          !(Map BS.ByteString (Name ::: Type))    -- free variables in CNF clause-          Type                                    -- the $i type-          !(Closed ())                            -- name generation-type Parser = Parsec ParsecState-type ParsecState = UserState ParseState TokenStream---- An include-clause.-data IncludeStatement = Include BS.ByteString (Maybe [Tag]) deriving Show---- The initial parser state.-initialState :: ParseState-initialState = MkState [] (Map.insert (BS.pack "$i") typeI Map.empty) Map.empty Map.empty typeI closed0-  where typeI = Type nameI Infinite Infinite--instance Stream TokenStream Token where-  primToken (At _ (Cons Eof _)) ok err fatal = err-  primToken (At _ (Cons L.Error _)) ok err fatal = fatal "Lexical error"-  primToken (At _ (Cons t ts)) ok err fatal = ok ts t-  type Position TokenStream = TokenStream-  position = id---- Wee function for testing.-testParser :: Parser a -> String -> Either [String] a-testParser p s = snd (run (const []) p (UserState initialState (scan (BSL.pack s))))--getProblem :: Parser [Input Form]-getProblem = do-  MkState p _ _ _ _ _ <- getState-  return (reverse p)---- Primitive parsers.--{-# INLINE keyword' #-}-keyword' p = satisfy p'-  where p' Atom { L.keyword = k } = p k-        p' _ = False-{-# INLINE keyword #-}-keyword k = keyword' (== k) <?> "'" ++ show k ++ "'"-{-# INLINE punct' #-}-punct' p = satisfy p'-  where p' Punct { L.kind = k } = p k-        p' _ = False-{-# INLINE punct #-}-punct k = punct' (== k) <?> "'" ++ show k ++ "'"-{-# INLINE defined' #-}-defined' p = fmap L.defined (satisfy p')-  where p' Defined { L.defined = d } = p d-        p' _ = False-{-# INLINE defined #-}-defined k = defined' (== k) <?> "'" ++ show k ++ "'"-{-# INLINE variable #-}-variable = fmap name (satisfy p) <?> "variable"-  where p L.Var{} = True-        p _ = False-{-# INLINE number #-}-number = fmap value (satisfy p) <?> "number"-  where p Number{} = True-        p _ = False-{-# INLINE atom #-}-atom = fmap name (keyword' (const True)) <?> "atom"---- Combinators.--parens, bracks :: Parser a -> Parser a-{-# INLINE parens #-}-parens p = between (punct LParen) (punct RParen) p-{-# INLINE bracks #-}-bracks p = between (punct LBrack) (punct RBrack) p---- Build an expression parser from a binary-connective parser--- and a leaf parser.-binExpr :: Parser a -> Parser (a -> a -> Parser a) -> Parser a-binExpr leaf op = do-  lhs <- leaf-  do { f <- op; rhs <- binExpr leaf op; f lhs rhs } <|> return lhs---- Parsing clauses.---- Parse as many things as possible until EOF or an include statement.-section :: (Tag -> Bool) -> Parser (Maybe IncludeStatement)-section included = skipMany (input included) >> (fmap Just include <|> (eof >> return Nothing))---- A single non-include clause.-input :: (Tag -> Bool) -> Parser ()-input included = declaration Cnf (formulaIn cnf) <|>-                 declaration Fof (formulaIn fof) <|>-                 declaration Tff (\tag -> formulaIn tff tag <|> typeDeclaration)-  where {-# INLINE declaration #-}-        declaration k m = do-          keyword k-          parens $ do-            t <- tag-            punct Comma-            -- Don't bother typechecking clauses that we are not-            -- supposed to include in the problem (seems in the-            -- spirit of TPTP's include mechanism)-            if included t then m t else balancedParens-          punct Dot-          return ()-        formulaIn lang tag = do-          k <- kind-          punct Comma-          form <- lang-          newFormula (k tag form)-        balancedParens = skipMany (parens balancedParens <|> (satisfy p >> return ()))-        p Punct{L.kind=LParen} = False-        p Punct{L.kind=RParen} = False-        p _ = True---- A TPTP kind.-kind :: Parser (Tag -> Form -> Input Form)-kind = axiom Axiom <|> axiom Hypothesis <|> axiom Definition <|>-       axiom Assumption <|> axiom Lemma <|> axiom Theorem <|>-       general Conjecture Form.Conjecture <|>-       general NegatedConjecture Form.Axiom <|>-       general Question Form.Question-  where axiom t = general t Form.Axiom-        general k kind = keyword k >> return (mk kind)-        mk kind tag form =-          Input { Form.tag = tag,-                  Form.kind = kind,-                  Form.what = form }---- A formula name.-tag :: Parser Tag-tag = atom <|> fmap (BS.pack . show) number <?> "clause name"---- An include declaration.-include :: Parser IncludeStatement-include = do-  keyword L.Include-  res <- parens $ do-    name <- atom <?> "quoted filename"-    clauses <- do { punct Comma-                  ; fmap Just (bracks (sepBy1 tag (punct Comma))) } <|> return Nothing-    return (Include name clauses)-  punct Dot-  return res---- Inserting types, functions and clauses.--newFormula :: Input Form -> Parser ()-newFormula input = do-  MkState p t f v i n <- getState-  putState (MkState (input:p) t f Map.empty i n)-  -newNameFrom :: Named a => Closed () -> a -> (Closed (), Name)-newNameFrom n name = (close_ n' (return ()), open n')-  where n' = close_ n (newName name)--{-# INLINE findType #-}-findType :: BS.ByteString -> Parser Type-findType name = do-  MkState p t f v i n <- getState-  case Map.lookup name t of-    Nothing -> do-      let (n', name') = newNameFrom n name-          ty = Type { tname = name', tmonotone = Infinite, tsize = Infinite }-      putState (MkState p (Map.insert name ty t) f v i n')-      return ty-    Just x -> return x--newFunction :: BS.ByteString -> FunType -> Parser (Name ::: FunType)-newFunction name ty' = do-  f@(_ ::: ty) <- lookupFunction ty' name-  unless (ty == ty') $ do-    fatalError $ "Constant " ++ BS.unpack name ++-                 " was declared to have type " ++ prettyShow ty' ++-                 " but already has type " ++ prettyShow ty-  return f--{-# INLINE applyFunction #-}-applyFunction :: BS.ByteString -> [Term] -> Type -> Parser Term-applyFunction name args' res = do-  i <- individual-  f@(_ ::: ty) <- lookupFunction (FunType (replicate (length args') i) res) name-  unless (map typ args' == args ty) $ typeError f args'-  return (f :@: args')--{-# NOINLINE typeError #-}-typeError f@(x ::: ty) args' = do-    let plural 1 x y = x -        plural _ x y = y-    fatalError $ "Type mismatch in term '" ++ prettyShow (f :@: args') ++ "': " ++-                 "Constant " ++ prettyShow x ++-                 if length (args ty) == length args' then-                   " has type " ++ prettyShow ty ++-                   " but was applied to " ++ plural (length args') "an argument" "arguments" ++-                   " of type " ++ prettyShow (map typ args')-                 else-                   " has arity " ++ show (length args') ++-                   " but was applied to " ++ show (length (args ty)) ++-                   plural (length (args ty)) " argument" " arguments"--{-# INLINE lookupFunction #-}-lookupFunction :: FunType -> BS.ByteString -> Parser (Name ::: FunType)-lookupFunction def name = do-  MkState p t f v i n <- getState-  case Map.lookup name f of-    Nothing -> do-      let (n', name') = newNameFrom n name-          decl = name' ::: def-      putState (MkState p t (Map.insert name decl f) v i n')-      return decl-    Just f -> return f---- The type $i (anything whose type is not specified gets this type)-{-# INLINE individual #-}-individual :: Parser Type-individual = do-  MkState _ _ _ _ i _ <- getState-  return i---- Parsing formulae.--cnf, tff, fof :: Parser Form-cnf =-  let ?binder = fatalError "Can't use quantifiers in CNF"-      ?ctx = Nothing-  in fmap (ForAll . bind) formula-tff =-  let ?binder = varDecl True-      ?ctx = Just Map.empty-  in formula-fof =-  let ?binder = varDecl False-      ?ctx = Just Map.empty-  in formula---- We cannot always know whether what we are parsing is a formula or a--- term, since we don't have lookahead. For example, p(x) might be a--- formula, but in p(x)=y, p(x) is a term.------ To deal with this, we introduce the Thing datatype.--- A thing is either a term or a formula, or a literal that we don't know--- if it should be a term or a formula. Instead of a separate formula-parser--- and term-parser we have a combined thing-parser.-data Thing = Apply !BS.ByteString ![Term]-           | Term !Term-           | Formula !Form--instance Show Thing where-  show (Apply f []) = BS.unpack f-  show (Apply f args) =-    BS.unpack f ++-      case args of-        [] -> ""-        args -> prettyShow args-  show (Term t) = prettyShow t-  show (Formula f) = prettyShow f---- However, often we do know whether we want a formula or a term,--- and there it's best to use a specialised parser (not least because--- the error messages are better). For that reason, our parser is--- parametrised on the type of thing you want to parse. We have two--- main parsers:---   * 'term' parses an atomic expression---   * 'formula' parses an arbitrary expression--- You can instantiate 'term' for Term, Form or Thing; in each case--- you get an appropriate parser. You can instantiate 'formula' for--- Form or Thing.---- Types for which a term f(...) is a valid literal. These are the types on--- which you can use 'term'.-class TermLike a where-  -- Convert from a Thing.-  fromThing :: Thing -> Parser a-  -- Parse a variable occurrence as a term on its own, if that's allowed.-  var :: (?ctx :: Maybe (Map BS.ByteString Variable)) => Parser a-  -- A parser for this type.-  parser :: (?binder :: Parser Variable,-             ?ctx :: Maybe (Map BS.ByteString Variable)) => Parser a--instance TermLike Form where-  {-# INLINE fromThing #-}-  fromThing t@(Apply x xs) = fmap (Literal . Pos . Tru) (applyFunction x xs O)-  fromThing (Term _) = mzero-  fromThing (Formula f) = return f-  -- A variable itself is not a valid formula.-  var = mzero-  parser = formula--instance TermLike Term where-  {-# INLINE fromThing #-}-  fromThing t@(Apply x xs) = individual >>= applyFunction x xs-  fromThing (Term t) = return t-  fromThing (Formula _) = mzero-  parser = term-  var = do-    x <- variable-    case ?ctx of-      Nothing -> do-        MkState p t f vs i n <- getState-        case Map.lookup x vs of-          Just v -> return (Var v)-          Nothing -> do-            let (n', name) = newNameFrom n x-                v = name ::: i-            putState (MkState p t f (Map.insert x v vs) i n')-            return (Var v)-      Just ctx ->-        case Map.lookup x ctx of-          Just v -> return (Var v)-          Nothing -> fatalError $ "unbound variable " ++ BS.unpack x--instance TermLike Thing where-  fromThing = return-  var = fmap Term var-  parser = formula---- Types that can represent formulae. These are the types on which--- you can use 'formula'.-class TermLike a => FormulaLike a where-  fromFormula :: Form -> a-instance FormulaLike Form where fromFormula = id-instance FormulaLike Thing where fromFormula = Formula---- An atomic expression.-{-# SPECIALISE term :: (?binder :: Parser Variable, ?ctx :: Maybe (Map BS.ByteString Variable)) => Parser Term #-}-{-# SPECIALISE term :: (?binder :: Parser Variable, ?ctx :: Maybe (Map BS.ByteString Variable)) => Parser Form #-}-{-# SPECIALISE term :: (?binder :: Parser Variable, ?ctx :: Maybe (Map BS.ByteString Variable)) => Parser Thing #-}-term :: (?binder :: Parser Variable, ?ctx :: Maybe (Map BS.ByteString Variable), TermLike a) => Parser a-term = function <|> var <|> parens parser-  where {-# INLINE function #-}-        function = do-          x <- atom-          args <- parens (sepBy1 term (punct Comma)) <|> return []-          fromThing (Apply x args)--literal, unitary, quantified, formula ::-  (?binder :: Parser Variable, ?ctx :: Maybe (Map BS.ByteString Variable), FormulaLike a) => Parser a-{-# INLINE literal #-}-literal = true <|> false <|> binary <?> "literal"-  where {-# INLINE true #-}-        true = do { defined DTrue; return (fromFormula (And S.Nil)) }-        {-# INLINE false #-}-        false = do { defined DFalse; return (fromFormula (Or S.Nil)) }-        binary = do-          x <- term :: Parser Thing-          let {-# INLINE f #-}-              f p sign = do-               punct p-               lhs <- fromThing x :: Parser Term-               rhs <- term :: Parser Term-               let form = Literal . sign $ lhs :=: rhs-               when (typ lhs /= typ rhs) $-                 fatalError $ "Type mismatch in equality '" ++ prettyShow form ++ -                              "': left hand side has type " ++ prettyShow (typ lhs) ++-                              " but right hand side has type " ++ prettyShow (typ rhs)-               return (fromFormula form)-          f Eq Pos <|> f Neq Neg <|> fromThing x--{-# SPECIALISE unitary :: (?binder :: Parser Variable, ?ctx :: Maybe (Map BS.ByteString Variable)) => Parser Form #-}-{-# SPECIALISE unitary :: (?binder :: Parser Variable, ?ctx :: Maybe (Map BS.ByteString Variable)) => Parser Thing #-}-unitary = negation <|> quantified <|> literal-  where {-# INLINE negation #-}-        negation = do-          punct L.Not-          fmap (fromFormula . Not) (unitary :: Parser Form)--{-# INLINE quantified #-}-quantified = do-  q <- (punct L.ForAll >> return ForAll) <|>-       (punct L.Exists >> return Exists)-  vars <- bracks (sepBy1 ?binder (punct Comma))-  let Just ctx = ?ctx-      ctx' = foldl' (\m v -> Map.insert (Name.base (Name.name v)) v m) ctx vars-  punct Colon-  rest <- let ?ctx = Just ctx' in (unitary :: Parser Form)-  return (fromFormula (q (Bind (NameMap.fromList vars) rest)))---- A general formula.-{-# SPECIALISE formula :: (?binder :: Parser Variable, ?ctx :: Maybe (Map BS.ByteString Variable)) => Parser Form #-}-{-# SPECIALISE formula :: (?binder :: Parser Variable, ?ctx :: Maybe (Map BS.ByteString Variable)) => Parser Thing #-}-formula = do-  x <- unitary :: Parser Thing-  let binop op t u = op (S.Unit t `S.append` S.Unit u)-      {-# INLINE connective #-}-      connective p op = do-        punct p-        lhs <- fromThing x-        rhs <- formula :: Parser Form-        return (fromFormula (op lhs rhs))-  connective L.And (binop And) <|> connective L.Or (binop Or) <|>-   connective Iff Equiv <|>-   connective L.Implies (Connective Implies) <|>-   connective L.Follows (Connective Follows) <|>-   connective L.Xor (Connective Xor) <|>-   connective L.Nor (Connective Nor) <|>-   connective L.Nand (Connective Nand) <|>-   fromThing x---- varDecl True: parse a typed variable binding X:a or an untyped one X--- varDecl False: parse an untyped variable binding X-varDecl :: Bool -> Parser Variable-varDecl typed = do-  x <- variable-  ty <- do { punct Colon;-             when (not typed) $-               fatalError "Used a typed quantification in an untyped formula";-             type_ } <|> individual-  MkState p t f v i n <- getState-  let (n', name) = newNameFrom n x-  putState (MkState p t f v i n')-  return (name ::: ty)---- Parse a type-type_ :: Parser Type-type_ =-  do { name <- atom; findType name } <|>-  do { defined DI; individual }---- A little data type to help with parsing types.-data Type_ = TType | Fun [Type] Type | Prod [Type]--prod :: Type_ -> Type_ -> Parser Type_-prod (Prod tys) (Prod tys2) | not (O `elem` tys ++ tys2) = return $ Prod (tys ++ tys2)-prod _ _ = fatalError "invalid type"--arrow :: Type_ -> Type_ -> Parser Type_-arrow (Prod ts) (Prod [x]) = return $ Fun ts x-arrow _ _ = fatalError "invalid type"--leaf :: Parser Type_-leaf = do { defined DTType; return TType } <|>-       do { defined DO; return (Prod [O]) } <|>-       do { ty <- type_; return (Prod [ty]) } <|>-       parens compoundType--compoundType :: Parser Type_-compoundType = leaf `binExpr` (punct Times >> return prod)-                    `binExpr` (punct FunArrow >> return arrow)--typeDeclaration :: Parser ()-typeDeclaration = do-  keyword L.Type-  punct Comma-  let manyParens p = parens (manyParens p) <|> p-  manyParens $ do-    name <- atom-    punct Colon-    res <- compoundType-    case res of-      TType -> do { findType name; return () }-      Fun args res -> do { newFunction name (FunType args res); return () }-      Prod [res] -> do { newFunction name (FunType [] res); return () }-      _ -> fatalError "invalid type"
− Jukebox/TPTP/FindFile.hs 
@@ -1,41 +0,0 @@-module Jukebox.TPTP.FindFile where--import System.FilePath-import System.Directory(doesFileExist)-import System.Environment-import Control.Applicative-import Control.Exception-import Control.Monad-import Prelude hiding (catch)-import Jukebox.Options-import Data.Traversable(sequenceA)--findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)-findFile [] file = return Nothing-findFile (path:paths) file = do-  let candidate = path </> file-  exists <- doesFileExist candidate-  if exists then return (Just candidate)-   else findFile paths file--findFileTPTP :: [FilePath] -> FilePath -> IO (Maybe FilePath)-findFileTPTP dirs file = do-  let candidates = [file, "Problems" </> file,-                    "Problems" </> take 3 file </> file]-  fmap msum (mapM (findFile dirs) candidates)--getTPTPDirs :: IO [FilePath]-getTPTPDirs = do { dir <- getEnv "TPTP"; return [dir] } `catch` f-  where f :: IOException -> IO [FilePath]-        f _ = return []--findFileFlags =-  concat <$>-  sequenceA [-    pure ["."],-    flag "root"-      ["Extra directories that will be searched for TPTP input files."]-      []-      argFiles,-    io getTPTPDirs-    ]
− Jukebox/TPTP/Lexer.x 
@@ -1,223 +0,0 @@--- -*- mode: haskell -*----- Roughly taken from the TPTP syntax reference-{-{-# OPTIONS_GHC -O2 -fno-warn-deprecated-flags #-}-{-# LANGUAGE BangPatterns #-}-module Jukebox.TPTP.Lexer(-  scan,-  Pos(..),-  Token(..),-  Punct(..),-  Defined(..),-  Keyword(..),-  TokenStream(..),-  Contents(..)) where--import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.ByteString.Lazy.Internal-import Data.Word-import Data.Char-}--$alpha = [a-zA-Z0-9_]-$anything = [. \n]-@quoted = ($printable # [\\']) | \\ $printable-@dquoted = ($printable # [\\\"]) | \\ $printable--tokens :---- Comments and whitespace-"%" .* ;-"/*" (($anything # \*)* "*"+-      ($anything # [\/\*]))*-     ($anything # \*)* "*"* "*/" ; -- blech!-$white+ ;---- Keywords.-"thf" { k Thf }-"tff" { k Tff }-"fof" { k Fof }-"cnf" { k Cnf }-"axiom" { k Axiom }-"hypothesis" { k Hypothesis }-"definition" { k Definition }-"assumption" { k Assumption }-"lemma" { k Lemma }-"theorem" { k Theorem }-"conjecture" { k Conjecture }-"negated_conjecture" { k NegatedConjecture }-"question" { k Question }-"plain" { k Plain }-"fi_domain" { k FiDomain }-"fi_hypothesis" { k FiHypothesis }-"fi_predicates" { k FiPredicates }-"type" { k Type }-"unknown" { k Unknown }-"include" { k Include }--- Defined symbols.-"$true" { d DTrue }-"$false" { d DFalse }-"$equal" { d DEqual }-"$distinct" { d DDistinct }-"$itef" { d DItef }-"$itett" | "$itetf" { d DItet }-"$o" | "$oType" { d DO }-"$i" | "$iType" { d DI }-"$tType" { d DTType }--- Atoms.-"$"{0,2} [a-z] $alpha* { Atom Normal . copy }--- Atoms with funny quoted names (here we diverge from the official--- syntax, which only allows the escape sequences \\ and \' in quoted--- atoms: we allow \ to be followed by any printable character)-"'"  @quoted+ "'" { Atom Normal . unquote }--- Vars are easy :)-[A-Z][$alpha]* { Var . copy }--- Distinct objects, which are double-quoted-\" @dquoted+  \" { DistinctObject . unquote }--- Integers-[\+\-]? (0 | [1-9][0-9]*)/($anything # $alpha) { Number . readNumber }---- Operators (FOF)-"("  { p LParen }  ")"   { p RParen }  "["  { p LBrack }   "]"  { p RBrack }-","  { p Comma }   "."   { p Dot }     "|"  { p Or }       "&"  { p And }-"~"  { p Not }     "<=>" { p Iff }     "=>" { p Implies }  "<=" { p Follows }-"<~>"{ p Xor }     "~|"  { p Nor }     "~&" { p Nand }     "="  { p Eq }-"!=" { p Neq }     "!"   { p ForAll }  "?"  { p Exists }   ":=" { p Let }-":-" { p LetTerm }--- Operators (TFF)-":" { p Colon }    "*"   { p Times }   "+"  { p Plus }     ">"  { p FunArrow }--- Operators (THF)-"^"  { p Lambda } "@" { p Apply }  "!!" { p ForAllLam }  "??"  { p ExistsLam }-"@+" { p Some }   "@-" { p The }   "<<" { p Subtype }    "-->" { p SequentArrow }-"!>" { p DependentProduct }        "?*" { p DependentSum }--{-data Pos = Pos {-# UNPACK #-} !Word {-# UNPACK #-} !Word deriving Show-data Token = Atom { keyword :: !Keyword, name :: !BS.ByteString }-           | Defined { defined :: !Defined  }-           | Var { name :: !BS.ByteString }-           | DistinctObject { name :: !BS.ByteString }-           | Number { value :: !Integer }-           | Punct { kind :: !Punct }-           | Eof-           | Error--data Keyword = Normal-             | Thf | Tff | Fof | Cnf-             | Axiom | Hypothesis | Definition | Assumption-             | Lemma | Theorem | Conjecture | NegatedConjecture | Question-             | Plain | FiDomain | FiHypothesis | FiPredicates | Type | Unknown-             | Include deriving (Eq, Ord)--instance Show Keyword where-  show x =-    case x of {-      Normal -> "normal";-      Thf -> "thf"; Tff -> "tff"; Fof -> "fof"; Cnf -> "cnf";-      Axiom -> "axiom"; Hypothesis -> "hypothesis"; Definition -> "definition";-      Assumption -> "assumption"; Lemma -> "lemma"; Theorem -> "theorem";-      Conjecture -> "conjecture"; NegatedConjecture -> "negated_conjecture";-      Question -> "question"; Plain -> "plain"; FiDomain -> "fi_domain";-      FiHypothesis -> "fi_hypothesis"; FiPredicates -> "fi_predicates";-      Type -> "type"; Unknown -> "unknown"; Include -> "include" }---- We only include defined names that need special treatment from the--- parser here: you can freely make up any other names starting with a--- '$' and they get turned into Atoms.-data Defined = DTrue | DFalse | DEqual | DDistinct | DItef | DItet-             | DO | DI | DTType deriving (Eq, Ord)--instance Show Defined where-  show x =-    case x of {-      DTrue -> "$true"; DFalse -> "$false"; DEqual -> "$equal";-      DDistinct -> "$distinct"; DItef -> "$itef"; DItet -> "$itet";-      DO -> "$o"; DI -> "$i"; DTType -> "$tType" }--data Punct = LParen | RParen | LBrack | RBrack | Comma | Dot-           | Or | And | Not | Iff | Implies | Follows | Xor | Nor | Nand-           | Eq | Neq | ForAll | Exists | Let | LetTerm -- FOF-           | Colon | Times | Plus | FunArrow -- TFF-           | Lambda | Apply | ForAllLam | ExistsLam-           | DependentProduct | DependentSum | Some | The-           | Subtype | SequentArrow -- THF-             deriving (Eq, Ord)--instance Show Punct where-  show x =-    case x of {-      LParen -> "("; RParen -> ")"; LBrack -> "["; RBrack -> "]";-      Comma -> ","; Dot -> "."; Or -> "|"; And -> "&"; Not -> "~";-      Iff -> "<=>"; Implies -> "=>"; Follows -> "<="; Xor -> "<~>";-      Nor -> "~|"; Nand -> "~&"; Eq -> "="; Neq -> "!="; ForAll -> "!";-      Exists -> "?"; Let -> ":="; Colon -> ":"; Times -> "*"; Plus -> "+";-      FunArrow -> ">"; Lambda -> "^"; Apply -> "@"; ForAllLam -> "!!";-      ExistsLam -> "??"; Some -> "@+"; The -> "@-"; Subtype -> "<<";-      SequentArrow -> "-->"; DependentProduct -> "!>"; DependentSum -> "?*" }--p x = const (Punct x)-k x = Atom x . copy-d x = const (Defined x)--copy :: BS.ByteString -> BS.ByteString-copy = id -- could change to a string interning function later--unquote :: BS.ByteString -> BS.ByteString-unquote x =-  case BSL.toChunks (BSL.tail (unquote' x)) of-    [] -> BS.empty-    [x] -> copy x-    xs -> BS.concat xs--unquote' :: BS.ByteString -> BSL.ByteString-unquote' x | BS.null z = chunk (BS.init y) Empty-           | otherwise = chunk y (BS.index z 1 `BSL.cons'` unquote' (BS.drop 2 z))-           where (y, z) = BS.break (== '\\') x-    -readNumber :: BS.ByteString -> Integer-readNumber x | BS.null r = n-  where Just (n, r) = BS.readInteger x---- The main scanner function, heavily modified from Alex's posn-bytestring wrapper.--data TokenStream = At {-# UNPACK #-} !Pos !Contents-data Contents = Cons !Token TokenStream--scan xs = go (Input (Pos 1 1) '\n' BS.empty xs)-  where go inp@(Input pos _ x xs) =-          case alexScan inp 0 of-                AlexEOF -> let t = At pos (Cons Eof t) in t-                AlexError _ -> let t = At pos (Cons Error t) in t-                AlexSkip  inp' len -> go inp'-                AlexToken inp' len act ->-                  let token | len <= BS.length x = BS.take len x-                            | otherwise = BS.concat (BSL.toChunks (BSL.take (fromIntegral len) (chunk x xs)))-                  in At pos (act token `Cons` go inp')--data AlexInput = Input {-# UNPACK #-} !Pos {-# UNPACK #-} !Char {-# UNPACK #-} !BS.ByteString BSL.ByteString--alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (Input p c x xs) = c--{-# INLINE alexGetByte #-}-alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)-alexGetByte i = fmap f (alexGetChar i)-  where f (c, i') = (fromIntegral (ord c), i')-{-# INLINE alexGetChar #-}-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)-alexGetChar (Input p _ x xs) | not (BS.null x) = getCharNonEmpty p x xs-alexGetChar (Input p _ _ (Chunk x xs)) = getCharNonEmpty p x xs-alexGetChar (Input p _ _ Empty) = Nothing-{-# INLINE getCharNonEmpty #-}-getCharNonEmpty p x xs =-  let !c = BS.head x-      !next = Input (advance p c) c (BS.tail x) xs-  in Just (c, next)--{-# INLINE advance #-}-advance :: Pos -> Char -> Pos-advance (Pos l c) '\t' = Pos  l    (c+8 - (c-1) `mod` 8)-advance (Pos l c) '\n' = Pos (l+1) 1-advance (Pos l c) _    = Pos  l    (c+1)-}
− Jukebox/TPTP/ParseProblem.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Jukebox.TPTP.ParseProblem where--import Jukebox.ProgressBar-import Jukebox.TPTP.FindFile-import Jukebox.TPTP.ClauseParser-import Jukebox.TPTP.Lexer hiding (Include, Error)-import Jukebox.TPTP.Parsec-import Jukebox.TPTP.Print-import qualified Jukebox.TPTP.Lexer as L-import Control.Monad.Error-import Jukebox.Form hiding (Pos)-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.ByteString.Char8 as BS-import Control.Monad.Identity-import Control.Exception-import Prelude hiding (catch)-import Data.List-import Jukebox.Name--parseProblem :: [FilePath] -> FilePath -> IO (Either String (Problem Form))-parseProblem dirs name = withProgressBar $ \pb -> parseProblemWith (findFileTPTP dirs) pb name--parseProblemWith :: (FilePath -> IO (Maybe FilePath)) -> ProgressBar -> FilePath -> IO (Either String (Problem Form))-parseProblemWith findFile progressBar name = runErrorT (fmap finalise (parseFile name Nothing "<command line>" (Pos 0 0) initialState))-  where err :: String -> Pos -> String -> ErrorT String IO a-        err file (Pos l c) msg = throwError msg'-          where msg' = "Error at " ++ file ++ " (line " ++ show l ++ ", column " ++ show c ++ "):\n" ++ msg-        liftMaybeIO :: IO (Maybe a) -> FilePath -> Pos -> String -> ErrorT String IO a-        liftMaybeIO m file pos msg = do-          x <- liftIO m-          case x of-            Nothing -> err file pos msg-            Just x -> return x-        liftEitherIO :: IO (Either a b) -> FilePath -> Pos -> (a -> String) -> ErrorT String IO b-        liftEitherIO m file pos msg = do-          x <- liftIO m-          case x of-            Left e -> err file pos (msg e)-            Right x -> return x--        parseFile :: FilePath -> Maybe [Tag] -> FilePath -> Pos ->-                     ParseState -> ErrorT FilePath IO ParseState-        parseFile name clauses file0 pos st = do-          file <- liftMaybeIO (findFile name) file0 pos ("File " ++ name ++ " not found")-          liftIO $ enter progressBar $ "Reading " ++ file-          contents <- liftEitherIO-                        (fmap Right (BSL.readFile file >>= tickOnRead progressBar)-                          `catch` (\(e :: IOException) -> return (Left e)))-                        file (Pos 0 0) show-          let s = UserState st (scan contents)-          fmap userState (parseSections clauses file s)--        parseSections :: Maybe [Tag] -> FilePath -> ParsecState -> ErrorT String IO ParsecState-        parseSections clauses file s =-          let report UserState{userStream = At _ (Cons Eof _)} =-                ["Unexpected end of file"]-              report UserState{userStream = At _ (Cons L.Error _)} =-                ["Lexical error"]-              report UserState{userStream = At _ (Cons t _)} =-                ["Unexpected " ++ show t] in-          case run report (section (included clauses)) s of-            (UserState{userStream=At pos _}, Left e) ->-              err file pos (concat (intersperse "\n" e))-            (s'@UserState{userStream=At _ (Cons Eof _)}, Right Nothing) -> do-              liftIO $ leave progressBar-              return s'-            (UserState{userStream=stream@(At pos _),userState=state},-             Right (Just (Include name clauses'))) -> do-              s' <- parseFile (BS.unpack name) (clauses `merge` clauses') file pos state-              parseSections clauses file (UserState s' stream)--        included :: Maybe [Tag] -> Tag -> Bool-        included Nothing _ = True-        included (Just xs) x = x `elem` xs--        merge :: Maybe [Tag] -> Maybe [Tag] -> Maybe [Tag]-        merge Nothing x = x-        merge x Nothing = x-        merge (Just xs) (Just ys) = Just (xs `intersect` ys)--        finalise :: ParseState -> Problem Form-        finalise (MkState p _ _ _ _ n) = close_ n (return (reverse p))
− Jukebox/TPTP/ParseSnippet.hs 
@@ -1,45 +0,0 @@--- Parse little bits of TPTP, e.g. a prelude for a particular tool.--module Jukebox.TPTP.ParseSnippet where--import Jukebox.TPTP.ClauseParser as TPTP.ClauseParser-import Jukebox.TPTP.Parsec as TPTP.Parsec-import Jukebox.TPTP.Lexer-import Jukebox.Name-import Jukebox.Form-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.ByteString.Char8 as BS-import Control.Applicative-import qualified Jukebox.Map as Map-import Data.List--tff, cnf :: [(String, Type)] -> [(String, Function)] -> String -> NameM Form-tff = form TPTP.ClauseParser.tff-cnf = form TPTP.ClauseParser.cnf--form parser types funs str = supply (form' parser types funs str)--form' parser types funs str cl =-  let state0 = MkState [] (pack types) (pack funs) Map.empty iType cl-      pack xs = Map.fromList [(BS.pack x, y) | (x, y) <- xs]-      unpack m = [(BS.unpack x, y) | (x, y) <- Map.toList m]-      iType =-        case lookup "$i" types of-          Just x -> x-          Nothing -> error "ParseSnippet: use explicit type declarations" in-  case run_ (parser <* eof)-            (UserState state0 (scan (BSL.pack str))) of-    Ok (UserState state (At _ (Cons Eof _))) res ->-      case state of-        MkState _ types' funs' vars _ _-          | pack types /= types' ->-            error $ "ParseSnippet: type implicitly defined: " ++-                    show (map snd (unpack types' \\ types))-          | pack funs /= funs' ->-            error $ "ParseSnippet: function implicitly defined: " ++-                    show (map snd (unpack funs' \\ funs))-        MkState _ _ _ _ _ cl' ->-          fmap (const res) cl'-    Ok{} -> error "ParseSnippet: lexical error"-    TPTP.Parsec.Error _ msg -> error $ "ParseSnippet: parse error: " ++ msg-    Expected _ exp -> error $ "ParseSnippet: parse error: expected " ++ show exp
− Jukebox/TPTP/Parsec.hs 
@@ -1,174 +0,0 @@-{-# LANGUAGE RankNTypes, BangPatterns, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeFamilies #-}-module Jukebox.TPTP.Parsec where--import Control.Applicative-import Control.Monad-import Data.List---- Parser type and monad instances--newtype Parsec a b = Parsec-  { runParsec :: forall c.-                 (b -> Reply a c -> a -> Reply a c) -- ok: success-              -> Reply a c -- err: backtracking failure-              -> a -> Reply a c }--type Reply a b = [String] -> Result (Position a) b--data Result a b = Ok a b | Error a String | Expected a [String]--{-# INLINE parseError #-}-parseError :: [String] -> Parsec a b-parseError e = Parsec (\ok err inp exp -> err (e ++ exp))--{-# INLINE fatalError #-}-fatalError :: Stream a c => String -> Parsec a b-fatalError e = Parsec (\ok err inp _ -> Error (position inp) e)--instance Functor (Parsec a) where-  {-# INLINE fmap #-}-  fmap f x = x >>= return . f--instance Monad (Parsec a) where-  {-# INLINE return #-}-  return x = Parsec (\ok err inp exp -> ok x err inp exp)-  {-# INLINE (>>=) #-}-  x >>= f = Parsec (\ok err inp exp  -> runParsec x (\y err inp exp -> runParsec (f y) ok err inp exp) err inp exp)-  {-# INLINE fail #-}-  fail _ = parseError []--instance MonadPlus (Parsec a) where-  {-# INLINE mzero #-}-  mzero = Parsec (\ok err inp exp -> err exp)-  {-# INLINE mplus #-}-  m1 `mplus` m2 = Parsec (\ok err inp exp ->-    runParsec m1 ok (\exp -> runParsec m2 ok err inp exp) inp exp)--instance Applicative (Parsec a) where-  {-# INLINE pure #-}-  pure = return-  {-# INLINE (<*>) #-}-  f <*> x = do { f' <- f; x' <- x; return (f' x') }-  {-# INLINE (*>) #-}-  (*>) = (>>)-  {-# INLINE (<*) #-}-  x <* y = do-    x' <- x-    y-    return x'--instance Alternative (Parsec a) where-  {-# INLINE empty #-}-  empty = mzero-  {-# INLINE (<|>) #-}-  (<|>) = mplus-  {-# INLINE some #-}-  some p = do { x <- nonempty p; xs <- many p; return (x:xs) }-  {-# INLINE many #-}-  many p = p' where p' = liftM2 (:) (nonempty p) p' <|> return []-  -- Stack overflow-avoiding version:-  -- many p = liftM reverse (p' [])-  --   where p' !xs = do { x <- nonempty p; p' (x:xs) } `mplus` return xs---- Basic combinators--{-# INLINE nonempty #-}-nonempty :: Parsec a b -> Parsec a b-nonempty p = p--{-# INLINE skipSome #-}-skipSome :: Parsec a b -> Parsec a ()-skipSome p = p' where p' = nonempty p >> (p' `mplus` return ())--{-# INLINE skipMany #-}-skipMany :: Parsec a b -> Parsec a ()-skipMany p = p' where p' = (nonempty p >> p') `mplus` return ()--{-# INLINE (<?>) #-}-infix 0 <?>-(<?>) :: Parsec a b -> String -> Parsec a b-p <?> text = Parsec (\ok err inp exp ->-  runParsec p ok err inp (text:exp))--{-# INLINE between #-}-between :: Parsec a b -> Parsec a c -> Parsec a d -> Parsec a d-between p q r = p *> r <* q--{-# INLINE sepBy1 #-}-sepBy1 :: Parsec a b -> Parsec a c -> Parsec a [b]-sepBy1 it sep = liftM2 (:) it (many (sep >> it))---- Running the parser--run_ :: Stream a c => Parsec a b -> a -> Result (Position a) b-run_ p x = runParsec p ok err x []-  where ok x _ inp _ = Ok (position inp) x-        err exp = Expected (position x) (reverse exp)--run :: Stream a c => (Position a -> [String]) -> Parsec a b -> a -> (Position a, Either [String] b)-run report p ts =-  case run_ p ts of-    Ok ts' x -> (ts', Right x)-    Error ts' e -> (ts', Left [e])-    Expected ts' e -> (ts', Left (expected (report ts') e))---- Reporting errors--expected :: [String] -> [String] -> [String]-expected unexpected [] = unexpected ++ ["Unknown error"]-expected unexpected expected =-  unexpected ++ [ "Expected " ++ list expected ]-  where list [exp] = exp-        list exp = intercalate ", " (init exp) ++ " or " ++ last exp---- Token streams--class Stream a b | a -> b where-  primToken :: a -> (a -> b -> c) -> c -> (String -> c) -> c-  type Position a-  position :: a -> Position a--{-# INLINE next #-}-next :: Stream a b => Parsec a b-next = Parsec (\ok err inp exp ->-  primToken inp (\inp' x -> ok x err inp' exp) (err exp) (Error (position inp)))--{-# INLINE cut #-}-cut :: Stream a b => Parsec a ()-cut = Parsec (\ok err inp exp -> ok () (Expected (position inp)) inp [])--{-# INLINE cut' #-}-cut' :: Stream a b => Parsec a c -> Parsec a c-cut' p = Parsec (\ok err inp exp -> runParsec p (\x _ inp' _ -> ok x err inp' []) err inp exp)--{-# INLINE satisfy #-}-satisfy :: Stream a b => (b -> Bool) -> Parsec a b-satisfy p = do-  t <- next-  guard (p t)-  cut-  return t--{-# INLINE eof #-}-eof :: Stream a b => Parsec a ()-eof = Parsec (\ok err inp exp ->-  primToken inp (\_ _ -> err ("end of file":exp)) (ok () err inp exp) (Error (position inp)))---- User state--data UserState state stream = UserState { userState :: !state, userStream :: !stream }--instance Stream a b => Stream (UserState state a) b where-  {-# INLINE primToken #-}-  primToken (UserState state stream) ok err =-    primToken stream (ok . UserState state) err-  type Position (UserState state a) = UserState state a-  position = id--{-# INLINE getState #-}-getState :: Parsec (UserState state a) state-getState = Parsec (\ok err inp@UserState{userState = state} exp -> ok state err inp exp)--{-# INLINE putState #-}-putState :: state -> Parsec (UserState state a) ()-putState state = Parsec (\ok err inp@UserState{userStream = stream} exp -> ok () err (UserState state stream) exp)
− Jukebox/TPTP/Print.hs 
@@ -1,200 +0,0 @@--- Pretty-printing of formulae. WARNING: icky code inside!-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, TypeOperators, FlexibleInstances #-}-module Jukebox.TPTP.Print(prettyShow, chattyShow, prettyFormula, prettyProblem, Level(..), Pretty)-       where--import qualified Data.ByteString.Char8 as BS-import Data.Char-import Text.PrettyPrint.HughesPJ-import qualified Jukebox.TPTP.Lexer as L-import Jukebox.Form-import Data.List-import qualified Jukebox.Map as Map-import qualified Jukebox.Seq as S-import qualified Jukebox.NameMap as NameMap-import Jukebox.NameMap(NameMap)-import Jukebox.Name--data Level = Normal | Chatty deriving (Eq, Ord)--class Pretty a where-  pPrint :: Int -> Level -> (Name -> BS.ByteString) -> a -> Doc--instance Pretty Name where-  pPrint _ _ env x = text (BS.unpack (env x))--pPrintSymbol :: Bool -> Int -> Level -> (Name -> BS.ByteString) -> Name ::: Type -> Doc-pPrintSymbol full prec lev env (x ::: t)-  | full || lev >= Chatty = pPrint prec lev env x <> colon <> pPrint prec lev env t-  | otherwise = pPrint prec lev env x--pPrintBinding prec lev env (x ::: t) =-  pPrintSymbol (name t /= nameI) prec lev env (x ::: typ t)--pPrintUse prec lev env (x ::: t) =-  pPrintSymbol False prec lev env (x ::: typ t)--instance Pretty Type where-  pPrint prec lev env O = pPrint prec lev env nameO-  pPrint prec lev env t-    | lev >= Chatty = -      hcat . punctuate (text "/") $-        [text (BS.unpack (escapeAtom (env (tname t))))] ++-        [size (tmonotone t) | tmonotone t /= Infinite || tsize t /= Infinite] ++-        [size (tsize t) | tsize t /= Infinite]-    | otherwise = text (BS.unpack (escapeAtom (env (tname t))))-    where size Infinite = empty-          size (Finite n) = int n--instance Show Type where-  show = chattyShow--instance Show L.Token where-  show L.Atom{L.name = x} = BS.unpack (escapeAtom x)-  show L.Defined{L.defined = x} = show x-  show L.Var{L.name = x} = BS.unpack x-  show L.DistinctObject{L.name = x} = BS.unpack (quote '"' x)-  show L.Number{L.value = x} = show x-  show L.Punct{L.kind = x} = show x-  show L.Eof = "end of file"-  show L.Error = "lexical error"--escapeAtom :: BS.ByteString -> BS.ByteString-escapeAtom s | not (BS.null s') && isLower (BS.head s') && BS.all isNormal s' = s-             | otherwise = quote '\'' s-  where isNormal c = isAlphaNum c || c == '_'-        s' = BS.dropWhile (== '$') s--quote :: Char -> BS.ByteString -> BS.ByteString-quote c s = BS.concat [BS.pack [c], BS.concatMap escape s, BS.pack [c]]-  where escape c' | c == c' = BS.pack ['\\', c]-        escape '\\' = BS.pack "\\\\"-        escape c = BS.singleton c--instance Pretty FunType where-  pPrint prec lev env FunType{args = args, res = res} =-    case args of-      [] -> pPrint prec lev env res-      args -> pPrint prec lev env args <+> text ">" <+>-              pPrint prec lev env res--instance Show FunType where-  show = chattyShow--instance Pretty [Type] where-  pPrint prec lev env [arg] = pPrint prec lev env arg-  pPrint prec lev env args =-    parens (hsep (intersperse (text "*")-                  (map (pPrint 0 lev env) args)))--prettyProblem :: (Symbolic a, Pretty a) => String -> Level -> Problem a -> Doc-prettyProblem family l prob = vcat (map typeDecl (S.unique (types prob')) ++-                                    map funcDecl (S.unique (functions prob')) ++-                                    map (prettyInput family l env) prob')-    where typeDecl ty | name ty `elem` open stdNames || isFof prob' = empty-                      | otherwise = typeClause ty (text "$tType")-          funcDecl (f ::: ty) | isFof prob' = empty-                              | otherwise = typeClause f (pPrint 0 l (escapeAtom . env) ty)-          typeClause name ty = prettyClause "tff" "type" "type"-                                      (pPrint 0 l (escapeAtom . env) name <+> colon <+> ty)-          env = uniquify (S.unique (names prob'))-          prob' = open prob--prettyClause :: String -> String -> String -> Doc -> Doc-prettyClause family name kind rest =-  text family <> parens (sep [text name <> comma <+> text kind <> comma, rest]) <> text "."--instance (Symbolic a, Pretty a) => Show (Problem a) where-  show = render . prettyProblem "tff" Chatty--prettyInput :: Pretty a => String -> Level -> (Name -> BS.ByteString) -> Input a -> Doc-prettyInput family l env i = prettyClause family (BS.unpack (tag i)) (show (kind i)) (pPrint 0 l env (what i))--instance Pretty a => Pretty (Input a) where-  pPrint _ l env = prettyInput "tff" l env--instance Pretty a => Show (Input a) where-  show = chattyShow--instance Pretty Term where-  pPrint _ l env (Var v) = pPrintUse 0 l env v-  pPrint _ l env (f :@: []) = pPrintUse 0 l (escapeAtom . env) f-  pPrint _ l env (f :@: ts) = pPrintUse 0 l (escapeAtom . env) f <> pPrint 0 l env ts-  -instance Pretty [Term] where-  pPrint _ l env ts = parens (sep (punctuate comma (map (pPrint 0 l env) ts)))--instance Show Term where-  show = chattyShow--instance Pretty Atomic where-  pPrint _ l env (t :=: u) = pPrint 0 l env t <> text "=" <> pPrint 0 l env u-  pPrint _ l env (Tru t) = pPrint 0 l env t--instance Show Atomic where-  show = chattyShow--instance Pretty Clause where-  pPrint p l env c@(Clause (Bind vs ts))-    | and [ name (typ v) == nameI | v <- NameMap.toList vs ] =-       prettyConnective l p env "$false" "|" (map Literal ts)-    | otherwise =-       pPrint p l env (toForm c)--instance Show Clause where-  show = chattyShow--instance Pretty Form where-  -- We use two precedences, the lowest for binary connectives-  -- and the highest for everything else.-  pPrint p l env (Literal (Pos (t :=: u))) =-    pPrint 0 l env t <> text "=" <> pPrint 0 l env u-  pPrint p l env (Literal (Neg (t :=: u))) =-    pPrint 0 l env t <> text "!=" <> pPrint 0 l env u-  pPrint p l env (Literal (Pos t)) = pPrint p l env t-  pPrint p l env (Literal (Neg t)) = pPrint p l env (Not (Literal (Pos t)))-  pPrint p l env (Not f) = text "~" <> pPrint 1 l env f-  pPrint p l env (And ts) = prettyConnective l p env "$true" "&" (S.toList ts)-  pPrint p l env (Or ts) = prettyConnective l p env "$false" "|" (S.toList ts)-  pPrint p l env (Equiv t u) = prettyConnective l p env undefined "<=>" [t, u]-  pPrint p l env (ForAll (Bind vs f)) = prettyQuant l env "!" vs f-  pPrint p l env (Exists (Bind vs f)) = prettyQuant l env "?" vs f-  pPrint p l env (Connective c t u) = prettyConnective l p env (error "pPrint: Connective") (show c) [t, u]--instance Show Form where-  show = chattyShow--instance Show Connective where-  show Implies = "=>"-  show Follows = "<="-  show Xor = "<~>"-  show Nor = "~|"-  show Nand = "~&"--prettyConnective l p env ident op [] = text ident-prettyConnective l p env ident op [x] = pPrint p l env x-prettyConnective l p env ident op (x:xs) =-  prettyParen (p > 0) $-    sep (ppr x:[ nest 2 (text op <+> ppr x) | x <- xs ])-      where ppr = pPrint 1 l env-            -prettyParen False = id-prettyParen True = parens--prettyQuant l env q vs f | Map.null vs = pPrint 1 l env f-prettyQuant l env q vs f =-  sep [text q <> brackets (sep (punctuate comma (map (pPrintBinding 0 l env) (Map.elems vs)))) <> colon,-       nest 2 (pPrint 1 l env f)]--instance Show Kind where-  show Axiom = "axiom"-  show Conjecture = "conjecture"-  show Question = "question"--prettyShow, chattyShow :: Pretty a => a -> String-prettyShow = render . pPrint 0 Normal base-chattyShow = render . pPrint 0 Chatty (BS.pack . show)--prettyFormula :: (Pretty a, Symbolic a) => a -> String-prettyFormula prob = render . pPrint 0 Normal env $ prob-  where env = uniquify (S.unique (names prob))
− Jukebox/Toolbox.hs 
@@ -1,251 +0,0 @@-module Jukebox.Toolbox where--import Jukebox.Options-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import Jukebox.Form-import Jukebox.Name-import qualified Jukebox.NameMap as NameMap-import Jukebox.TPTP.Print-import Control.Monad-import Control.Applicative-import Jukebox.Clausify-import Jukebox.TPTP.ParseProblem-import Jukebox.Monotonox.Monotonicity hiding (guards)-import Jukebox.Monotonox.ToFOF-import System.Exit-import System.IO-import Jukebox.TPTP.FindFile-import Text.PrettyPrint.HughesPJ-import Jukebox.GuessModel-import Jukebox.InferTypes-import Jukebox.TPTP.Parsec hiding (Error)-import qualified Jukebox.TPTP.Parsec as Parser-import Jukebox.TPTP.ClauseParser-import Jukebox.TPTP.Lexer hiding (Error, name, Normal)-import qualified Jukebox.TPTP.Lexer as Lexer--data GlobalFlags =-  GlobalFlags {-    quiet :: Bool }-  deriving Show--globalFlags :: OptionParser GlobalFlags-globalFlags =-  inGroup "Global options" $-  GlobalFlags <$>-    bool "quiet"-      ["Do not print any informational output.",-       "Default: (off)"]--(=>>=) :: (Monad m, Applicative f) => f (a -> m b) -> f (b -> m c) -> f (a -> m c)-f =>>= g = (>=>) <$> f <*> g-infixl 1 =>>= -- same as >=>--(=>>) :: (Monad m, Applicative f) => f (m a) -> f (m b) -> f (m b)-x =>> y = (>>) <$> x <*> y-infixl 1 =>> -- same as >>--greetingBox :: Tool -> OptionParser (IO ())-greetingBox t = greetingBoxIO t <$> globalFlags--greetingBoxIO :: Tool -> GlobalFlags -> IO ()-greetingBoxIO t GlobalFlags{quiet = quiet} =-  unless quiet $ hPutStrLn stderr (greeting t)--allFilesBox :: OptionParser ((FilePath -> IO ()) -> IO ())-allFilesBox = flip allFiles <$> filenames--allFiles :: (FilePath -> IO ()) -> [FilePath] -> IO ()-allFiles _ [] = do-  hPutStrLn stderr "No input files specified! Try --help."-  exitWith (ExitFailure 1)-allFiles f xs = mapM_ f xs--parseProblemBox :: OptionParser (FilePath -> IO (Problem Form))-parseProblemBox = parseProblemIO <$> findFileFlags--parseProblemIO :: [FilePath] -> FilePath -> IO (Problem Form)-parseProblemIO dirs f = do-  r <- parseProblem dirs f-  case r of-    Left err -> do-      hPutStrLn stderr err-      exitWith (ExitFailure 1)-    Right x -> return x--withString :: (Symbolic a, Pretty a) => String -> (Problem Form -> IO (Problem a)) -> String -> IO String-withString kind f x = do-  let errorAt (UserState _ (At (Lexer.Pos l c) _)) err =-        error $ "At line " ++ show l ++ ", column " ++ show c ++ ": " ++ err-  case run_ (section (const True) <* eof)-            (UserState initialState (scan (BSL.pack x))) of-    Ok (UserState (MkState p _ _ _ _ n) (At _ (Cons Eof _))) Nothing -> do-      let prob = close_ n (return (reverse p))-      res <- f prob-      return (render (prettyProblem kind Normal res))-    Ok s@(UserState _ (At _ (Cons Eof _))) (Just _) ->-      errorAt s "can't handle include files"-    Ok s _ ->-      errorAt s "lexical error"-    Parser.Error s msg -> errorAt s $ "parse error: " ++ msg-    Expected s exp -> errorAt s $ "parse error: expected " ++ show exp--encodeString :: String -> IO String-encodeString = withString "fof" f-  where-    f = toFofIO globals (return . clausify clFlags) (tags False)-    globals = GlobalFlags { quiet = True }-    clFlags = ClausifyFlags { splitting = False }--clausifyBox :: OptionParser (Problem Form -> IO CNF)-clausifyBox = clausifyIO <$> globalFlags <*> clausifyFlags--clausifyIO :: GlobalFlags -> ClausifyFlags -> Problem Form -> IO CNF-clausifyIO globals flags prob = do-  unless (quiet globals) $ hPutStrLn stderr "Clausifying problem..."-  return $! clausify flags prob--toFofBox :: OptionParser (Problem Form -> IO (Problem Form))-toFofBox = toFofIO <$> globalFlags <*> clausifyBox <*> schemeBox--oneConjectureBox :: OptionParser (CNF -> IO (Problem Clause))-oneConjectureBox = pure oneConjecture--oneConjecture :: CNF -> IO (Problem Clause)-oneConjecture cnf = closedIO (close cnf f)-  where f (Obligs cs [cs'] _ _) = return (return (cs ++ cs'))-        f _ = return $ do-          hPutStrLn stderr "Error: more than one conjecture found in input problem"-          exitWith (ExitFailure 1)--toFofIO :: GlobalFlags -> (Problem Form -> IO CNF) -> Scheme -> Problem Form -> IO (Problem Form)-toFofIO globals clausify scheme f = do-  cs <- clausify f >>= oneConjecture-  unless (quiet globals) $ hPutStrLn stderr "Monotonicity analysis..."-  m <- monotone (map what (open cs))-  let isMonotone ty =-        case NameMap.lookup (name ty) m of-          Just (_ ::: Nothing) -> False-          Just (_ ::: Just _) -> True-          Nothing  -> True -- can happen if clausifier removed all clauses about a type-  return (translate scheme isMonotone f)--schemeBox :: OptionParser Scheme-schemeBox =-  choose <$>-  flag "encoding"-    ["Which type encoding to use.",-     "Default: --encoding guards"]-    "guards"-    (argOption ["guards", "tags"])-  <*> tagsFlags-  where choose "guards" flags = guards-        choose "tags" flags = tags flags--monotonicityBox :: OptionParser (Problem Clause -> IO String)-monotonicityBox = monotonicity <$> globalFlags--monotonicity :: GlobalFlags -> Problem Clause -> IO String-monotonicity globals cs = do-  unless (quiet globals) $ hPutStrLn stderr "Monotonicity analysis..."-  m <- monotone (map what (open cs))-  let info (ty ::: Nothing) = [BS.unpack (baseName ty) ++ ": not monotone"]-      info (ty ::: Just m) =-        [prettyShow ty ++ ": monotone"] ++-        concat-        [ case ext of-             CopyExtend -> []-             TrueExtend -> ["  " ++ BS.unpack (baseName p) ++ " true-extended"]-             FalseExtend -> ["  " ++ BS.unpack (baseName p) ++ " false-extended"]-        | p ::: ext <- NameMap.toList m ]--  return (unlines (concat (map info (NameMap.toList m))))--annotateMonotonicityBox :: OptionParser (Problem Clause -> IO (Problem Clause))-annotateMonotonicityBox = (\globals x -> do-  unless (quiet globals) $ putStrLn "Monotonicity analysis..."-  annotateMonotonicity x) <$> globalFlags--prettyPrintBox :: (Symbolic a, Pretty a) => OptionParser (Problem a -> IO ())-prettyPrintBox = prettyFormIO <$> globalFlags <*> writeFileBox--prettyFormIO :: (Symbolic a, Pretty a) => GlobalFlags -> (String -> IO ()) -> Problem a -> IO ()-prettyFormIO globals write prob-  | isFof (open prob) = prettyPrintIO globals "fof" write prob-  | otherwise = prettyPrintIO globals "tff" write prob--prettyClauseBox :: OptionParser (Problem Clause -> IO ())-prettyClauseBox = f <$> globalFlags <*> writeFileBox-  where-    f globals write cs-      | isFof (open cs) = prettyPrintIO globals "cnf" write cs-      | otherwise = prettyPrintIO globals "tff" write (fmap (map (fmap toForm)) cs)--prettyPrintIO :: (Symbolic a, Pretty a) => GlobalFlags -> String -> (String -> IO ()) -> Problem a -> IO ()-prettyPrintIO globals kind write prob = do-  unless (quiet globals) $ hPutStrLn stderr "Writing output..."-  write (render (prettyProblem kind Normal prob) ++ "\n")--writeFileBox :: OptionParser (String -> IO ())-writeFileBox =-  flag "output"-    ["Where to write the output.",-     "Default: stdout"]-    putStr-    (fmap myWriteFile argFile)-  where myWriteFile "/dev/null" _ = return ()-        myWriteFile file contents = writeFile file contents--guessModelBox :: OptionParser (Problem Form -> IO (Problem Form))-guessModelBox = guessModelIO <$> expansive <*> universe-  where universe = choose <$>-                   flag "universe"-                   ["Which universe to find the model in.",-                    "Default: peano"]-                   "peano"-                   (argOption ["peano", "trees"])-        choose "peano" = Peano-        choose "trees" = Trees-        expansive = manyFlags "expansive"-                    ["Allow a function to construct 'new' terms in its base base."]-                    (arg "<function>" "expected a function name" Just)--guessModelIO :: [String] -> Universe -> Problem Form -> IO (Problem Form)-guessModelIO expansive univ prob = return (guessModel expansive univ prob)--allObligsBox :: OptionParser ((Problem Clause -> IO Answer) -> Closed Obligs -> IO ())-allObligsBox = pure allObligsIO--allObligsIO solve obligs = loop 1 conjectures-  where Obligs { axioms = axioms, conjectures = conjectures,-                 satisfiable = satisfiable, unsatisfiable = unsatisfiable } =-          open obligs--        loop _ [] = result unsatisfiable-        loop i (c:cs) = do-          when multi $ putStrLn $ "Part " ++ part i-          answer <- solve (close_ obligs (return (axioms ++ c)))-          when multi $ putStrLn $ "+++ PARTIAL (" ++ part i ++ "): " ++ show answer-          case answer of-            Satisfiable -> result satisfiable-            Unsatisfiable -> loop (i+1) cs-            NoAnswer x -> result (show x)-        multi = length conjectures > 1-        part i = show i ++ "/" ++ show (length conjectures)-        result x = putStrLn ("+++ RESULT: " ++ x)--inferBox :: OptionParser (Problem Clause -> IO (Problem Clause, Type -> Type))-inferBox = (\globals prob -> do-  unless (quiet globals) $ putStrLn "Inferring types..."-  let prob' = close prob inferTypes-  return (fmap fst prob', snd (open prob'))) <$> globalFlags--printInferredBox :: OptionParser ((Problem Clause, Type -> Type) -> IO (Problem Clause))-printInferredBox = pure $ \(prob, rep) -> do-  forM_ (types (open prob)) $ \ty ->-    putStrLn $ show ty ++ " => " ++ show (rep ty)-  return prob--equinoxBox :: OptionParser (Problem Clause -> IO Answer)-equinoxBox = pure (\f -> return (NoAnswer GaveUp)) -- A highly sophisticated proof method. We are sure to win CASC! :)
− Jukebox/UnionFind.hs 
@@ -1,76 +0,0 @@-module Jukebox.UnionFind(UF, Replacement((:>)), (=:=), rep, evalUF, execUF, runUF, S, isRep, initial, reps) where--import Prelude hiding (min)-import Control.Monad.State.Strict-import Data.Hashable-import Jukebox.Map(Map)-import qualified Jukebox.Map as Map--type S a = Map a a-type UF a = State (S a)-data Replacement a = a :> a--runUF :: S a -> UF a b -> (b, S a)-runUF s m = runState m s--evalUF :: S a -> UF a b -> b-evalUF s m = fst (runUF s m)--execUF :: S a -> UF a b -> S a-execUF s m = snd (runUF s m)--initial :: S a-initial = Map.empty--(=:=) :: (Hashable a, Ord a) => a -> a -> UF a (Maybe (Replacement a))-s =:= t | s == t = return Nothing-s =:= t = do-  rs <- rep s-  rt <- rep t-  case rs `compare` rt of-    EQ -> return Nothing-    LT -> do-      modify (Map.insert rt rs)-      return (Just (rt :> rs))-    GT -> do-      modify (Map.insert rs rt)-      return (Just (rs :> rt))--{-# INLINE rep #-}-rep :: (Hashable a, Ord a) => a -> UF a a-rep s = do-  m <- get-  case Map.lookup s m of-    Nothing -> return s-    Just t -> do-      u <- rep t-      when (t /= u) $ modify (Map.insert s u)-      return u-      -- case Map.lookup t m of-      --   Nothing -> return t-      --   Just u -> do-      --     v <- rep' t u-      --     modify (Map.insert s v)-      --     return v--reps :: (Hashable a, Ord a) => UF a (a -> a)-reps = do-  s <- get-  return (\x -> evalUF s (rep x))---- rep' :: (Hashable a, Ord a) => a -> a -> UF a a--- rep' s t = do---   m <- get---   case Map.lookup t m of---     Nothing -> do---       modify (Map.insert s t)---       return t---     Just u -> do---       v <- rep' t u---       modify (Map.insert s v)---       return v--isRep :: (Hashable a, Ord a) => a -> UF a Bool-isRep t = do-  t' <- rep t-  return (t == t')
− Jukebox/Utils.hs 
@@ -1,38 +0,0 @@-{-# LANGUAGE TupleSections #-}-module Jukebox.Utils where--import Data.List-import qualified Jukebox.Seq as Seq-import qualified Data.HashSet as Set-import Data.Hashable-import System.Process-import qualified Data.ByteString.Char8 as BS-import System.IO-import System.Exit-import Control.Applicative-import Control.Concurrent--usort :: Ord a => [a] -> [a]-usort = map head . group . sort--merge :: Ord a => [a] -> [a] -> [a]-merge [] ys = ys-merge xs [] = xs-merge (x:xs) (y:ys) =-  case x `compare` y of-    LT -> x:merge xs (y:ys)-    EQ -> x:merge xs ys-    GT -> y:merge (x:xs) ys--nub :: (Seq.List f, Ord a, Hashable a) => f a -> [a]-nub = Set.toList . Set.fromList . Seq.toList--popen :: FilePath -> [String] -> BS.ByteString -> IO (ExitCode, BS.ByteString)-popen prog args inp = do-  (stdin, stdout, stderr_, pid) <- runInteractiveProcess prog args Nothing Nothing-  forkIO $ hGetContents stderr_ >>= hPutStr stderr-  BS.hPutStr stdin inp-  hFlush stdin-  hClose stdin-  code <- waitForProcess pid-  fmap (code,) (BS.hGetContents stdout) <* hClose stdout
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009-2014, Nick Smallbone, Koen Claessen, Ann Lillieström+Copyright (c) 2009-2016, Nick Smallbone, Koen Claessen, Ann Lillieström  All rights reserved.
− Main.hs 
@@ -1,87 +0,0 @@-module Main where--import Control.Monad-import Jukebox.Options-import Control.Applicative-import Data.Monoid-import Jukebox.Toolbox--tools = mconcat [fof, cnf, monotonox, guessmodel]--fof = tool info pipeline-  where-    info = Tool "fof" "Jukebox TFF-to-FOF translator" "1"-                "Translate from TFF (typed) to FOF (untyped)"-    pipeline =-      greetingBox info =>>-      allFilesBox <*>-        (parseProblemBox =>>=-         toFofBox =>>=-         prettyPrintBox)--monotonox = tool info pipeline-  where-    info = Tool "monotonox" "Monotonox" "1"-                "Monotonicity analysis"-    pipeline =-      greetingBox info =>>-      allFilesBox <*>-        (parseProblemBox =>>=-         clausifyBox =>>=-         oneConjectureBox =>>=-         monotonicityBox =>>=-         writeFileBox)--cnf = tool info pipeline-  where-    info = Tool "cnf" "Jukebox clausifier" "1"-                "Clausify a problem"-    pipeline =-      greetingBox info =>>-      allFilesBox <*>-        (parseProblemBox =>>=-         clausifyBox =>>=-         oneConjectureBox =>>=-         prettyClauseBox)--justparser = tool info pipeline-  where-    info = Tool "parser" "Parser" "1"-                "Just parse the problem"-    pipeline =-      greetingBox info =>>-      allFilesBox <*>-        (parseProblemBox =>>=-         clausifyBox =>>=-         oneConjectureBox =>>=-         inferBox =>>=-         printInferredBox =>>=-         annotateMonotonicityBox =>>=-         prettyPrintBox)--guessmodel = tool info pipeline-  where-    info = Tool "guessmodel" "Infinite model guesser" "1"-                "Guess an infinite model"-    pipeline =-      greetingBox info =>>-      allFilesBox <*>-        (parseProblemBox =>>=-         guessModelBox =>>=-         prettyPrintBox)--equinox = tool info pipeline-  where-    info = Tool "equinox" "Equinox" "7"-                "Prove a first-order problem"-    pipeline =-      greetingBox info =>>-      allFilesBox <*>-        (parseProblemBox =>>=-         clausifyBox =>>=-         allObligsBox <*> equinoxBox)--jukebox = Tool "jukebox" "Jukebox" "1"-               "A first-order logic toolbox"--main = join (parseCommandLine jukebox tools)
dist/build/Jukebox/TPTP/Lexer.hs view
@@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP,MagicHash #-}-{-# LINE 4 "Jukebox/TPTP/Lexer.x" #-}+{-# LINE 4 "src/Jukebox/TPTP/Lexer.x" #-}  {-# OPTIONS_GHC -O2 -fno-warn-deprecated-flags #-} {-# LANGUAGE BangPatterns #-}@@ -14,9 +14,6 @@   TokenStream(..),   Contents(..)) where -import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BSL-import Data.ByteString.Lazy.Internal import Data.Word import Data.Char @@ -51,13 +48,13 @@ alex_deflt = AlexA# "\xff\xff\x2e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x16\x00\x18\x00\x18\x00\x1a\x00\x1a\x00\x1f\x00\x1f\x00\x28\x00\x28\x00\x2d\x00\x2d\x00\x2e\x00\xff\xff\x2e\x00\x2e\x00\x30\x00\x2f\x00\x2f\x00\x30\x00\x36\x00\xff\xff\xff\xff\x36\x00\x36\x00\x04\x00\xff\xff\xff\xff\x04\x00\x04\x00\x2e\x00\x3d\x00\x3c\x00\x3c\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\x3e\x00\xff\xff\x3f\x00\x3e\x00\x3f\x00\x3e\x00\xff\xff\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#  alex_accept = listArray (0::Int,287) [AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccNone,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAccSkip,AlexAcc (alex_action_3),AlexAcc (alex_action_4),AlexAcc (alex_action_5),AlexAcc (alex_action_6),AlexAcc (alex_action_7),AlexAcc (alex_action_8),AlexAcc (alex_action_9),AlexAcc (alex_action_10),AlexAcc (alex_action_11),AlexAcc (alex_action_12),AlexAcc (alex_action_13),AlexAcc (alex_action_14),AlexAcc (alex_action_15),AlexAcc (alex_action_16),AlexAcc (alex_action_17),AlexAcc (alex_action_18),AlexAcc (alex_action_19),AlexAcc (alex_action_20),AlexAcc (alex_action_21),AlexAcc (alex_action_22),AlexAcc (alex_action_23),AlexAcc (alex_action_24),AlexAcc (alex_action_25),AlexAcc (alex_action_26),AlexAcc (alex_action_27),AlexAcc (alex_action_28),AlexAcc (alex_action_29),AlexAcc (alex_action_29),AlexAcc (alex_action_30),AlexAcc (alex_action_30),AlexAcc (alex_action_31),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_32),AlexAcc (alex_action_33),AlexAcc (alex_action_34),AlexAcc (alex_action_35),AlexAccPred  (alex_action_36) (alexRightContext 57)(AlexAccNone),AlexAccPred  (alex_action_36) (alexRightContext 57)(AlexAccNone),AlexAcc (alex_action_37),AlexAcc (alex_action_38),AlexAcc (alex_action_39),AlexAcc (alex_action_40),AlexAcc (alex_action_41),AlexAcc (alex_action_42),AlexAcc (alex_action_43),AlexAcc (alex_action_44),AlexAcc (alex_action_45),AlexAcc (alex_action_46),AlexAcc (alex_action_47),AlexAcc (alex_action_48),AlexAcc (alex_action_49),AlexAcc (alex_action_50),AlexAcc (alex_action_51),AlexAcc (alex_action_52),AlexAcc (alex_action_53),AlexAcc (alex_action_54),AlexAcc (alex_action_55),AlexAcc (alex_action_56),AlexAcc (alex_action_57),AlexAcc (alex_action_58),AlexAcc (alex_action_59),AlexAcc (alex_action_60),AlexAcc (alex_action_61),AlexAcc (alex_action_62),AlexAcc (alex_action_63),AlexAcc (alex_action_64),AlexAcc (alex_action_65),AlexAcc (alex_action_66),AlexAcc (alex_action_67),AlexAcc (alex_action_68),AlexAcc (alex_action_69),AlexAcc (alex_action_70),AlexAcc (alex_action_71)]-{-# LINE 95 "Jukebox/TPTP/Lexer.x" #-}+{-# LINE 92 "src/Jukebox/TPTP/Lexer.x" #-}  data Pos = Pos {-# UNPACK #-} !Word {-# UNPACK #-} !Word deriving Show-data Token = Atom { keyword :: !Keyword, name :: !BS.ByteString }+data Token = Atom { keyword :: !Keyword, tokenName :: !String }            | Defined { defined :: !Defined  }-           | Var { name :: !BS.ByteString }-           | DistinctObject { name :: !BS.ByteString }+           | Var { tokenName :: !String }+           | DistinctObject { tokenName :: !String }            | Number { value :: !Integer }            | Punct { kind :: !Punct }            | Eof@@ -114,51 +111,40 @@       Exists -> "?"; Let -> ":="; Colon -> ":"; Times -> "*"; Plus -> "+";       FunArrow -> ">"; Lambda -> "^"; Apply -> "@"; ForAllLam -> "!!";       ExistsLam -> "??"; Some -> "@+"; The -> "@-"; Subtype -> "<<";-      SequentArrow -> "-->"; DependentProduct -> "!>"; DependentSum -> "?*" }+      SequentArrow -> "-->"; DependentProduct -> "!>"; DependentSum -> "?*";+      LetTerm -> ":-" }  p x = const (Punct x) k x = Atom x . copy d x = const (Defined x) -copy :: BS.ByteString -> BS.ByteString-copy = id -- could change to a string interning function later--unquote :: BS.ByteString -> BS.ByteString-unquote x =-  case BSL.toChunks (BSL.tail (unquote' x)) of-    [] -> BS.empty-    [x] -> copy x-    xs -> BS.concat xs+copy :: String -> String+copy = id -unquote' :: BS.ByteString -> BSL.ByteString-unquote' x | BS.null z = chunk (BS.init y) Empty-           | otherwise = chunk y (BS.index z 1 `BSL.cons'` unquote' (BS.drop 2 z))-           where (y, z) = BS.break (== '\\') x+unquote :: String -> String+unquote (_:x)+  | null z = init y+  | otherwise = y ++ [z !! 1] ++ unquote (drop 2 z)+  where (y, z) = break (== '\\') x     -readNumber :: BS.ByteString -> Integer-readNumber x | BS.null r = n-  where Just (n, r) = BS.readInteger x- -- The main scanner function, heavily modified from Alex's posn-bytestring wrapper.  data TokenStream = At {-# UNPACK #-} !Pos !Contents data Contents = Cons !Token TokenStream -scan xs = go (Input (Pos 1 1) '\n' BS.empty xs)-  where go inp@(Input pos _ x xs) =+scan xs = go (Input (Pos 1 1) '\n' xs)+  where go inp@(Input pos _ xs) =           case alexScan inp 0 of                 AlexEOF -> let t = At pos (Cons Eof t) in t                 AlexError _ -> let t = At pos (Cons Error t) in t-                AlexSkip  inp' len -> go inp'+                AlexSkip  inp' _ -> go inp'                 AlexToken inp' len act ->-                  let token | len <= BS.length x = BS.take len x-                            | otherwise = BS.concat (BSL.toChunks (BSL.take (fromIntegral len) (chunk x xs)))-                  in At pos (act token `Cons` go inp')+                  At pos (act (take len xs) `Cons` go inp') -data AlexInput = Input {-# UNPACK #-} !Pos {-# UNPACK #-} !Char {-# UNPACK #-} !BS.ByteString BSL.ByteString+data AlexInput = Input {-# UNPACK #-} !Pos {-# UNPACK #-} !Char String  alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (Input p c x xs) = c+alexInputPrevChar (Input _ c _) = c  {-# INLINE alexGetByte #-} alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)@@ -166,19 +152,14 @@   where f (c, i') = (fromIntegral (ord c), i') {-# INLINE alexGetChar #-} alexGetChar :: AlexInput -> Maybe (Char,AlexInput)-alexGetChar (Input p _ x xs) | not (BS.null x) = getCharNonEmpty p x xs-alexGetChar (Input p _ _ (Chunk x xs)) = getCharNonEmpty p x xs-alexGetChar (Input p _ _ Empty) = Nothing-{-# INLINE getCharNonEmpty #-}-getCharNonEmpty p x xs =-  let !c = BS.head x-      !next = Input (advance p c) c (BS.tail x) xs-  in Just (c, next)+alexGetChar (Input p _ (x:xs)) =+  Just (x, Input (advance p x) x xs)+alexGetChar _ = Nothing  {-# INLINE advance #-} advance :: Pos -> Char -> Pos advance (Pos l c) '\t' = Pos  l    (c+8 - (c-1) `mod` 8)-advance (Pos l c) '\n' = Pos (l+1) 1+advance (Pos l _) '\n' = Pos (l+1) 1 advance (Pos l c) _    = Pos  l    (c+1)  alex_action_3 =  k Thf @@ -214,7 +195,7 @@ alex_action_33 =  Atom Normal . unquote  alex_action_34 =  Var . copy  alex_action_35 =  DistinctObject . unquote -alex_action_36 =  Number . readNumber +alex_action_36 =  Number . read  alex_action_37 =  p LParen  alex_action_38 =  p RParen  alex_action_39 =  p LBrack
+ executable/Main.hs view
@@ -0,0 +1,59 @@+module Main where++import Control.Monad+import Jukebox.Options+import Jukebox.Toolbox++tools = mconcat [fof, cnf, monotonox, guessmodel]++fof = tool info pipeline+  where+    info = Tool "fof" "Jukebox TFF-to-FOF translator" "1"+                "Translate from TFF (typed) to FOF (untyped)"+    pipeline =+      greetingBox info =>>+      allFilesBox <*>+        (parseProblemBox =>>=+         toFofBox =>>=+         prettyPrintProblemBox)++monotonox = tool info pipeline+  where+    info = Tool "monotonox" "Monotonox" "1"+                "Monotonicity analysis"+    pipeline =+      greetingBox info =>>+      allFilesBox <*>+        (parseProblemBox =>>=+         clausifyBox =>>=+         oneConjectureBox =>>=+         monotonicityBox =>>=+         writeFileBox)++cnf = tool info pipeline+  where+    info = Tool "cnf" "Jukebox clausifier" "1"+                "Clausify a problem"+    pipeline =+      greetingBox info =>>+      allFilesBox <*>+        (parseProblemBox =>>=+         clausifyBox =>>=+         oneConjectureBox =>>=+         prettyPrintClausesBox)++guessmodel = tool info pipeline+  where+    info = Tool "guessmodel" "Infinite model guesser" "1"+                "Guess an infinite model"+    pipeline =+      greetingBox info =>>+      allFilesBox <*>+        (parseProblemBox =>>=+         guessModelBox =>>=+         prettyPrintProblemBox)++jukebox = Tool "jukebox" "Jukebox" "1"+               "A first-order logic toolbox"++main = join (parseCommandLine jukebox tools)
jukebox.cabal view
@@ -1,10 +1,10 @@ Name: jukebox-Version: 0.1.6+Version: 0.2 Cabal-version: >= 1.8 Build-type: Simple Author: Nick Smallbone Maintainer: nicsma@chalmers.se-Copyright: 2009-2014 Nick Smallbone, Koen Claessen, Ann Lillieström+Copyright: 2009-2016 Nick Smallbone, Koen Claessen, Ann Lillieström  Category:            Logic @@ -23,47 +23,41 @@   location: https://github.com/nick8325/jukebox  Library-  Build-depends: bytestring, base >= 4 && < 5, array, mtl, directory,-    filepath, pretty, hashable, minisat,-    binary, unordered-containers, process, containers+  Build-depends: base >= 4 && < 5, array, transformers, directory,+    filepath, pretty, minisat, symbol, dlist,+    binary, unordered-containers, process, containers, uglymemo+  ghc-options: -W -fno-warn-incomplete-patterns   Build-tools: alex-  Ghc-options: -funfolding-use-threshold=500+  Hs-source-dirs: src+  include-dirs: src   Exposed-modules:     Jukebox.Clausify     Jukebox.Form     Jukebox.GuessModel     Jukebox.HighSat     Jukebox.InferTypes-    Jukebox.Map     Jukebox.Monotonox.Monotonicity     Jukebox.Monotonox.ToFOF     Jukebox.Name-    Jukebox.NameMap     Jukebox.Options-    Jukebox.ProgressBar     Jukebox.Provers.E     Jukebox.Provers.SPASS     Jukebox.Sat3     Jukebox.SatEq     Jukebox.Sat     Jukebox.SatMin-    Jukebox.Seq     Jukebox.Toolbox-    Jukebox.TPTP.ClauseParser+    Jukebox.TPTP.Parse.Core     Jukebox.TPTP.FindFile     Jukebox.TPTP.Lexer     Jukebox.TPTP.Parsec-    Jukebox.TPTP.ParseProblem+    Jukebox.TPTP.Parse     Jukebox.TPTP.ParseSnippet     Jukebox.TPTP.Print     Jukebox.UnionFind     Jukebox.Utils  Executable jukebox-  Main-is: Main.hs-  Build-depends: bytestring, base >= 4 && < 5, array, mtl, directory,-    filepath, pretty, hashable, minisat,-    binary, unordered-containers, process, containers,-    jukebox-  Build-tools: alex-  Ghc-options: -funfolding-use-threshold=500+  Main-is: executable/Main.hs+  Build-depends: base >= 4 && < 5, jukebox+  ghc-options: -W -fno-warn-incomplete-patterns
+ src/Jukebox/Clausify.hs view
@@ -0,0 +1,432 @@+{-# LANGUAGE TypeOperators, BangPatterns #-}+module Jukebox.Clausify where++import Jukebox.Form hiding (run)+import qualified Jukebox.Form as Form+import Jukebox.Name+import Data.List( maximumBy, sortBy, partition )+import Data.Ord+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Jukebox.Utils+import Jukebox.Options+import qualified Data.Set as Set+import Data.Set(Set)++newtype ClausifyFlags = ClausifyFlags { splitting :: Bool } deriving Show++clausifyFlags =+  inGroup "Clausifier options" $+  ClausifyFlags <$>+    bool "split"+      ["Split the conjecture into several sub-conjectures.",+       "Default: (off)"]++----------------------------------------------------------------------+-- clausify++clausify :: ClausifyFlags -> Problem Form -> CNF+clausify flags inps = Form.run inps (run . clausifyInputs [] [])+ where+  clausifyInputs theory obligs [] =+    do return (toCNF (reverse theory) (reverse obligs))+  +  clausifyInputs theory obligs (inp:inps) | kind inp == Axiom =+    do cs <- clausForm (tag inp) (what inp)+       clausifyInputs (cs ++ theory) obligs inps++  clausifyInputs theory obligs (inp:inps) | kind inp `elem` [Conjecture, Question] =+    do clausifyObligs theory obligs (tag inp) (split' (what inp)) inps++  clausifyObligs theory obligs _ [] inps =+    do clausifyInputs theory obligs inps+  +  clausifyObligs theory obligs s (a:as) inps =+    do cs <- clausForm s (nt a)+       clausifyObligs theory (cs:obligs) s as inps++  split' a | splitting flags = if null split_a then [true] else split_a+    where split_a = split a+  split' a                   = [a]++split :: Form -> [Form]+split p =+  case positive p of+    ForAll (Bind xs p) ->+      [ ForAll (Bind xs p') | p' <- split p ]+    +    And ps -> concatMap split ps+    +    p `Equiv` q ->+      split (nt p \/ q) ++ split (p \/ nt q)++    Or ps ->+      snd $+      maximumBy (comparing fst)+      [ (siz q, [ Or (q':qs) | q' <- sq ])+      | (q,qs) <- select ps+      , let sq = split q+      ]++    _ ->+      [p]+ where+  select []     = []+  select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ]+  +  siz (And ps)            = length ps+  siz (ForAll (Bind _ p)) = siz p+  siz (_ `Equiv` _)       = 2+  siz _                   = 0++{-  +    Or ps | length ps > 0 && n > 0 ->+      [ Or (p':ps') | p' <- split p ]+     where+      pns = [(p,siz p) | p <- ps]+      ((p,n),pns') = getMax (head pns) [] (tail pns)+      ps' = [ p' | (p',_) <- pns' ]+    +  getMax pn@(p,n) pns [] = (pn,pns)+  getMax pn@(p,n) pns (qm@(q,m):qms)+    | m > n     = getMax qm (pn:pns) qms+    | otherwise = getMax pn (qm:pns) qms+-}++----------------------------------------------------------------------+-- core clausification algorithm++clausForm :: String -> Form -> M [Input Clause]+clausForm s p =+  withName s $+    do miniscoped      <- miniscope . check . simplify         . check $ p+       noEquivPs       <- removeEquiv                          . check $ miniscoped+       noExistsPs      <- mapM removeExists                    . check $ noEquivPs+       noExpensiveOrPs <- fmap concat . mapM removeExpensiveOr . check $ noExistsPs+       noForAllPs      <- lift . mapM uniqueNames              . check $ noExpensiveOrPs+       let !cnf_        = concatMap cnf                        . check $ noForAllPs+           !simp        = simplifyCNF                          . check $ cnf_+           cs           = fmap clause                                  $ simp+           inps         = [ Input (s ++ i) Axiom c+                          | (c, i) <- zip cs ("":+                                        [ '_':show i | i <- [1..] ]) ]+       return $! force . check                                         $ inps++----------------------------------------------------------------------+-- miniscoping+miniscope :: Form -> M Form+miniscope t@Literal{} = return t+miniscope (Not f) = fmap Not (miniscope f)+miniscope (And fs) = fmap And (mapM miniscope fs)+miniscope (Or fs) = fmap Or (mapM miniscope fs)+miniscope (Equiv f g) = liftM2 Equiv (miniscope f) (miniscope g)+miniscope (ForAll (Bind xs f)) = miniscope f >>= forAll xs+miniscope (Exists (Bind xs f)) = miniscope f >>= forAll xs . nt >>= return . nt++forAll :: Set Variable -> Form -> M Form+forAll xs a | Set.null xs = return a+forAll xs a =+  case positive a of+    And as ->+      fmap And (mapM (forAll xs) as)+    +    ForAll (Bind ys a)+      | Set.null m -> return (ForAll (Bind ys a))+      | otherwise -> fmap (forAll' ys) (forAll m a)+      where m = xs Set.\\ ys+            forAll' vs (ForAll (Bind vs' t)) = ForAll (Bind (vs `Set.union` vs') t)+            forAll' vs t = ForAll (Bind vs t)++    Or as -> forAllOr xs [ (a, free a) | a <- as ]++    _ -> return (ForAll (Bind xs a))++forAllOr :: Set Variable -> [(Form, Set Variable)] -> M Form+forAllOr xs avss = do { y <- yes; forAll xs' (y \/ no) }+  where+    v         = head (Set.toList xs)+    xs'       = Set.delete v xs+    (bs1,bs2) = partition ((v `Set.member`) . snd) avss+    no        = orl [ b | (b,_) <- bs2 ]+    body      = orl [ b | (b,_) <- bs1 ]+    yes       = case bs1 of+                  []      -> return (orl [])+                  [(b,_)] -> forAll (Set.singleton v) b+                  _       -> return (ForAll (Bind (Set.singleton v) body))+    orl       = foldr (\/) false++----------------------------------------------------------------------+-- removing equivalences++-- removeEquiv p -> ps :+--   POST: And ps is equivalent to p (modulo extra symbols)+--   POST: ps has no Equiv and no Not+removeEquiv :: Form -> M [Form]+removeEquiv p =+  do (defs,pos,_) <- removeEquivAux False p+     return (pos:defs)++-- removeEquivAux inEquiv p -> (defs,pos,neg) :+--   PRE: inEquiv is True when we are "under" an Equiv+--   POST: defs is a list of definitions, under which+--         pos is equivalent to p and neg is equivalent to nt p+-- (the reason why "neg" and "nt pos" can be different, is+-- because we want to always code an equivalence as+-- a conjunction of two disjunctions, which leads to fewer+-- clauses -- the "neg" part of the result for the case Equiv+-- below makes use of this)+removeEquivAux :: Bool -> Form -> M ([Form],Form,Form)+removeEquivAux inEquiv p =+  case simple p of+    Not p ->+      do (defs,pos,neg) <- removeEquivAux inEquiv p+         return (defs,neg,pos)+  +    And ps ->+      do dps <- sequence [ removeEquivAux inEquiv p | p <- ps ]+         let (defss,poss,negs) = unzip3 dps+         return ( concat defss+                , And poss+                , Or  negs+                )++    ForAll (Bind xs p) ->+      do (defs,pos,neg) <- removeEquivAux inEquiv p+         return ( defs+                , ForAll (Bind xs pos)+                , Exists (Bind xs neg)+                )++    p `Equiv` q ->+      do (defsp,posp,negp)    <- removeEquivAux True p+         (defsq,posq,negq)    <- removeEquivAux True q+         (defsp',posp',negp') <- makeCopyable inEquiv posp negp+         (defsq',posq',negq') <- makeCopyable inEquiv posq negq+         return ( concat [defsp, defsq, defsp', defsq']+                , (negp' \/ posq') /\ (posp' \/ negq')+                , (negp' \/ negq') /\ (posp' \/ posq')+                )++    Literal l ->+      do return ([],Literal l,Literal (neg l))++-- makeCopyable turns an argument to an Equiv into something that we are+-- willing to copy. There are two such cases: (1) when the Equiv is+-- not under another Equiv (because we have to copy arguments to an Equiv+-- at least once anyway), (2) if the formula is small.+-- All other formulas will be made small (by means of a definition)+-- before we copy them.+makeCopyable :: Bool -> Form -> Form -> M ([Form],Form,Form)+makeCopyable inEquiv pos neg+  | isSmall pos || not inEquiv =+    -- we skolemize here so that we reuse the skolem function+    -- (if we do this after copying, we get several skolemfunctions)+    do pos' <- removeExists pos+       neg' <- removeExists neg+       return ([],pos',neg')++  | otherwise =+    do dp <- literal "equiv" (free pos)+       return ([Literal (Neg dp) \/ pos, Literal (Pos dp) \/ neg], Literal (Pos dp), Literal (Neg dp))+ where+  -- a formula is small if it is already a literal+  isSmall (Literal _)         = True+  isSmall (Not p)             = isSmall p+  isSmall (ForAll (Bind _ p)) = isSmall p+  isSmall (Exists (Bind _ p)) = isSmall p+  isSmall _                   = False++----------------------------------------------------------------------+-- skolemization++-- removeExists p -> p'+--   PRE: p has no Equiv and no Not+--   POST: p' is equivalent to p (modulo extra symbols)+--   POST: p' has no Equiv, no Exists, and no Not+removeExists :: Form -> M Form+removeExists (And ps) =+  do ps <- sequence [ removeExists p | p <- ps ]+     return (And ps)++removeExists (Or ps) =+  do ps <- sequence [ removeExists p | p <- ps ]+     return (Or ps)+    +removeExists (ForAll (Bind xs p)) =+  do p' <- removeExists p+     return (ForAll (Bind xs p'))+    +removeExists t@(Exists (Bind xs p)) =+  -- skolemterms have only variables as arguments, arities are large(r)+  do ss <- sequence [ fmap (x |=>) (skolem x (free t)) | x <- Set.toList xs ]+     removeExists (subst (foldr (|+|) ids ss) p)+  {-+  -- skolemterms can have other skolemterms as arguments, arities are small(er)+  -- disadvantage: skolemterms are very complicated and deep+  do p' <- skolemize p+     t <- skolem x (delete x (free p'))+     return (subst (x |=> t) p')+  -}++removeExists lit =+  do return lit++-- TODO: Avoid recomputing "free" at every step, by having+-- skolemize return the set of free variables as well++-- TODO: Investigate skolemizing top-down instead, find the right+-- optimization++----------------------------------------------------------------------+-- make cheap Ors++removeExpensiveOr :: Form -> M [Form]+removeExpensiveOr p =+  do (defs,p',_) <- removeExpensiveOrAux p+     return (p':defs)++-- cost: represents how it expensive it is to clausify a formula+type Cost = (Integer,Integer) -- (#clauses, #literals)++unitCost :: Cost+unitCost = (1,1)++andCost :: [Cost] -> Cost+andCost cs = (sum (map fst cs), sum (map snd cs))++orCost :: [Cost] -> Cost+orCost []           = (1,0)+orCost [c]          = c+orCost ((c1,l1):cs) = (c1 * c2, c1 * l2 + c2 * l1)+ where+  (c2,l2) = orCost cs+  +removeExpensiveOrAux :: Form -> M ([Form],Form,Cost)+removeExpensiveOrAux (And ps) =+  do dcs <- sequence [ removeExpensiveOrAux p | p <- ps ]+     let (defss,ps,costs) = unzip3 dcs+     return (concat defss, And ps, andCost costs)++removeExpensiveOrAux (Or ps) =+  do dcs <- sequence [ removeExpensiveOrAux p | p <- ps ]+     let (defss,ps,costs) = unzip3 dcs+     (defs2,p,c) <- makeOr (sortBy (comparing snd) (zip ps costs))+     return (defs2 ++ concat defss,p,c)++removeExpensiveOrAux (ForAll (Bind xs p)) =+  do (defs,p',cost) <- removeExpensiveOrAux p+     return (fmap (ForAll . Bind xs) defs, ForAll (Bind xs p'), cost)++removeExpensiveOrAux lit =+  do return ([], lit, unitCost)++-- input is sorted; small costs first+makeOr :: [(Form,Cost)] -> M ([Form],Form,Cost)+makeOr [] =+  do return ([], false, orCost [])++makeOr [(f,c)] =+  do return ([],f,c)++makeOr fcs+  | null fcs2 =+    do return ([], Or (map fst fcs1), orCost (map snd fcs1))++  | otherwise =+    do d <- literal "or" (free (map fst fcs2))+       (defs,p,_) <- makeOr ((Literal (Neg d),unitCost):fcs2)+       return ( p:defs+              , Or (Literal (Pos d) : map fst fcs1)+              , orCost (unitCost : map snd fcs1)+              )+ where+  (fcs1,fcs2) = split [] fcs+  +  split fcs1 []                            = (fcs1,[])+  split fcs1 (fc@(_,(cc,_)):fcs) | cc <= 1 = split (fc:fcs1) fcs+  split fcs1 fcs@((_,(cc,_)):_)  | cc <= 2 = (take 2 fcs ++ fcs1, drop 2 fcs)+  split fcs1 fcs                           = (take 1 fcs ++ fcs1, drop 1 fcs)++----------------------------------------------------------------------+-- clausification++-- cnf p = cs+--   PRE: p has no Equiv, no Exists, and no Not,+--        and each variable is only bound once+--   POST: And (map Or cs) is equivalent to p+cnf :: Form -> [[Literal]]+cnf (ForAll (Bind _ p)) = cnf p+cnf (And ps)            = concatMap cnf ps+cnf (Or ps)             = cross (fmap cnf ps)+cnf (Literal x)         = [[x]]++cross :: [[[Literal]]] -> [[Literal]]+cross [] = [[]]+cross (cs:css) = liftM2 (++) cs (cross css)++----------------------------------------------------------------------+-- simplification of CNF++simplifyCNF :: [[Literal]] -> [[Literal]]+simplifyCNF =+  -- usort: don't generate multiple copies of identical clauses+  usort . concatMap (tautElim . unify [])+  where -- remove negative variable equalities X != Y by substitution+        unify xs [] = xs+        unify xs (Neg (Var v :=: t@Var{}):ys) =+          unify (subst (v |=> t) xs) (subst (v |=> t) ys)+        unify xs (l:ys) = unify (l:xs) ys+        -- simplify p | ~p or t = t to true.+        tautElim ls+          | Set.null (pos `Set.intersection` neg) && not (any tauto ls)+            -- reorder the order of the literals in the clause+            -- so that more clauses become equal;+            -- also, remove duplicate literals from the clause+            = [map Neg (Set.toList neg) ++ map Pos (Set.toList pos)]+          | otherwise = []+          where pos = Set.fromList [ l | Pos l <- ls ]+                neg = Set.fromList [ l | Neg l <- ls ]+                tauto (Pos (t :=: u)) = t == u+                tauto _ = False++----------------------------------------------------------------------+-- monad++type M = ReaderT Tag NameM++run :: M a -> NameM a+run x = runReaderT x ""++skolemName :: Named a => String -> a -> M Name+skolemName prefix v = do+  s <- getName+  name <- lift (newName v)+  return $ withRenamer name $ \str i ->+    Renaming [prefix ++ show (i+1)] $+      prefix ++ show (i+1) ++ concat [ "_" ++ t | t <- [s, str], not (null t) ]++withName :: Tag -> M a -> M a+withName s m = lift (runReaderT m s)++getName :: M Tag+getName = ask++skolem :: Variable -> Set Variable -> M Term+skolem (v ::: t) vs =+  do n <- skolemName "sK" v+     let f = n ::: FunType (map typ args) t+     return (f :@: map Var args)+ where+  args = Set.toList vs++literal :: String -> Set Variable -> M Atomic+literal w vs =+  do n <- skolemName "sP" w+     let p = n ::: FunType (map typ args) O+     return (Tru (p :@: map Var args))+ where+  args = Set.toList vs++----------------------------------------------------------------------+-- the end.
+ src/Jukebox/Form.hs view
@@ -0,0 +1,669 @@+-- Formulae, inputs, terms and so on.+--+-- "Show" instances for several of these types are found in TPTP.Print.++{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, Rank2Types, GADTs, TypeOperators, ScopedTypeVariables, BangPatterns, PatternGuards #-}+module Jukebox.Form where++import Prelude hiding (sequence, mapM)+import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Map.Strict as Map+import Data.Map(Map)+import Data.Ord+import Jukebox.Name+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Data.List+import Jukebox.Utils+import Data.Typeable(Typeable)+import Data.Monoid+import qualified Data.DList as DList+import Data.DList(DList)+import Data.MemoUgly++-- Set to True to switch on some sanity checks+debugging :: Bool+debugging = False++----------------------------------------------------------------------+-- Types++data DomainSize = Finite Int | Infinite deriving (Eq, Ord, Show, Typeable)++data Type =+    O+  | Type {+      tname :: !Name,+      -- type is monotone when domain size is >= tmonotone+      tmonotone :: DomainSize,+      -- if there is a model of size >= tsize then there is a model of size tsize+      tsize :: DomainSize } deriving Typeable++data FunType = FunType { args :: [Type], res :: Type } deriving (Eq, Typeable)++-- Helper function for defining (Eq, Ord) instances+typeMaybeName :: Type -> Maybe Name+typeMaybeName O = Nothing+typeMaybeName Type{tname = t} = Just t++instance Eq Type where+  t1 == t2 = typeMaybeName t1 == typeMaybeName t2++instance Ord Type where+  compare = comparing typeMaybeName++instance Named Type where+  name O = name "$o"+  name Type{tname = t} = t++-- Typeclass of "things that have a type"+class Typed a where+  typ :: a -> Type++instance Typed Type where+  typ = id++instance Typed FunType where+  typ = res++instance Typed b => Typed (a ::: b) where+  typ (_ ::: t) = typ t++----------------------------------------------------------------------+-- Terms++type Variable = Name ::: Type+type Function = Name ::: FunType+data Term = Var Variable | Function :@: [Term] deriving (Eq, Ord)++instance Named Term where+  name (Var x) = name x+  name (f :@: _) = name f++instance Typed Term where+  typ (Var x) = typ x+  typ (f :@: _) = typ f++newSymbol :: Named a => a -> b -> NameM (Name ::: b)+newSymbol x ty = fmap (::: ty) (newName x)++newFunction :: Named a => a -> [Type] -> Type -> NameM Function+newFunction x args res = newSymbol x (FunType args res)++newType :: Named a => a -> NameM Type+newType x = do+  n <- newName x+  return (Type n Infinite Infinite)++funArgs :: Function -> [Type]+funArgs (_ ::: ty) = args ty++arity :: Function -> Int+arity = length . funArgs++size :: Term -> Int+size Var{} = 1+size (_f :@: xs) = 1 + sum (map size xs)++----------------------------------------------------------------------+-- Literals++infix 8 :=:+data Atomic = Term :=: Term | Tru Term++-- Helper for (Eq Atomic, Ord Atomic) instances+normAtomic :: Atomic -> Either (Term, Term) Term+normAtomic (t1 :=: t2) | t1 > t2 = Left (t2, t1)+                       | otherwise = Left (t1, t2)+normAtomic (Tru p) = Right p++instance Eq Atomic where+  t1 == t2 = normAtomic t1 == normAtomic t2++instance Ord Atomic where+  compare = comparing normAtomic++data Signed a = Pos a | Neg a deriving (Show, Eq, Ord)++instance Functor Signed where+  fmap f (Pos x) = Pos (f x)+  fmap f (Neg x) = Neg (f x)+type Literal = Signed Atomic++neg :: Signed a -> Signed a+neg (Pos x) = Neg x+neg (Neg x) = Pos x++the :: Signed a -> a+the (Pos x) = x+the (Neg x) = x++pos :: Signed a -> Bool+pos (Pos _) = True+pos (Neg _) = False++signForm :: Signed a -> Form -> Form+signForm (Pos _) f = f+signForm (Neg _) f = Not f++----------------------------------------------------------------------+-- Formulae++-- Invariant: each name is bound only once on each path+-- i.e. nested quantification of the same variable twice is not allowed+-- Not OK: ![X]: (... ![X]: ...)+-- OK:     (![X]: ...) & (![X]: ...)+-- Free variables must also not be bound inside subformulae+data Form+  = Literal Literal+  | Not Form+  | And [Form]+  | Or [Form]+  | Equiv Form Form+  | ForAll {-# UNPACK #-} !(Bind Form)+  | Exists {-# UNPACK #-} !(Bind Form)+    -- Just exists so that parsing followed by pretty-printing is+    -- somewhat lossless; the simplify function will get rid of it+  | Connective Connective Form Form++-- Miscellaneous connectives that exist in TPTP+data Connective = Implies | Follows | Xor | Nor | Nand++connective :: Connective -> Form -> Form -> Form+connective Implies t u = nt t \/ u+connective Follows t u = t \/ nt u+connective Xor t u = nt (t `Equiv` u)+connective Nor t u = nt (t \/ u)+connective Nand t u = nt (t /\ u)++data Bind a = Bind (Set Variable) a++true, false :: Form+true = And []+false = Or []++isTrue, isFalse :: Form -> Bool+isTrue (And []) = True+isTrue _ = False+isFalse (Or []) = True+isFalse _ = False++nt :: Form -> Form+nt (Not a) = a+nt a       = Not a++(.=>.) :: Form -> Form -> Form+(.=>.) = connective Implies++(.=.) :: Term -> Term -> Form+t .=. u | typ t == O = Literal (Pos (Tru t)) `Equiv` Literal (Pos (Tru u))+        | otherwise = Literal (Pos (t :=: u))++(/\), (\/) :: Form -> Form -> Form+And as /\ And bs = And (as ++ bs)+a      /\ b | isFalse a || isFalse b = false+And as /\ b      = And (b:as)+a      /\ And bs = And (a:bs)+a      /\ b      = And [a, b]++Or as \/ Or bs = Or (as ++ bs)+a     \/ b | isTrue a || isTrue b = true+Or as \/ b     = Or (b:as)+a     \/ Or bs = Or (a:bs)+a     \/ b     = Or [a, b]++closeForm :: Form -> Form+closeForm f | Set.null vars = f+            | otherwise = ForAll (Bind vars f)+  where vars = free f++-- remove Not from the root of a problem+positive :: Form -> Form+positive (Not f) = notInwards f+-- Some connectives are fairly not-ish+positive (Connective c t u)         = positive (connective c t u)+positive f = f++notInwards :: Form -> Form+notInwards (And as)             = Or (fmap notInwards as)+notInwards (Or as)              = And (fmap notInwards as)+notInwards (a `Equiv` b)        = notInwards a `Equiv` b+notInwards (Not a)              = positive a+notInwards (ForAll (Bind vs a)) = Exists (Bind vs (notInwards a))+notInwards (Exists (Bind vs a)) = ForAll (Bind vs (notInwards a))+notInwards (Literal l)          = Literal (neg l)+notInwards (Connective c t u)   = notInwards (connective c t u)++-- remove Exists and Or from the top level of a formula+simple :: Form -> Form+simple (Or as)              = Not (And (fmap nt as))+simple (Exists (Bind vs a)) = Not (ForAll (Bind vs (nt a)))+simple (Connective c t u)   = simple (connective c t u)+simple a                    = a++-- perform some easy algebraic simplifications+simplify t@Literal{} = t+simplify (Connective c t u) = simplify (connective c t u)+simplify (Not t) = simplify (notInwards t)+simplify (And ts) = foldr (/\) true (fmap simplify ts)+simplify (Or ts) = foldr (\/) false (fmap simplify ts)+simplify (Equiv t u) = equiv (simplify t) (simplify u)+  where equiv t u | isTrue t = u+                  | isTrue u = t+                  | isFalse t = nt u+                  | isFalse u = nt t+                  | otherwise = Equiv t u+simplify (ForAll (Bind vs t)) = forAll vs (simplify t)+  where forAll vs t | Set.null vs = t+        forAll vs (ForAll (Bind vs' t)) = ForAll (Bind (Set.union vs vs') t)+        forAll vs t = ForAll (Bind vs t)+simplify (Exists (Bind vs t)) = exists vs (simplify t)+  where exists vs t | Set.null vs = t+        exists vs (Exists (Bind vs' t)) = Exists (Bind (Set.union vs vs') t)+        exists vs t = Exists (Bind vs t)++----------------------------------------------------------------------+-- Clauses++data CNF =+  CNF {+    axioms :: [Input Clause],+    conjectures :: [[Input Clause]],+    satisfiable :: String,+    unsatisfiable :: String }++toCNF :: [Input Clause] -> [[Input Clause]] -> CNF+toCNF axioms [] = CNF axioms [[]] "Satisfiable" "Unsatisfiable"+toCNF axioms [conjecture] = CNF axioms [conjecture] "CounterSatisfiable" "Theorem"+toCNF axioms conjectures = CNF axioms conjectures "GaveUp" "Theorem"++newtype Clause = Clause (Bind [Literal])++clause :: [Signed Atomic] -> Clause+clause xs = Clause (bind xs)++toForm :: Clause -> Form+toForm (Clause (Bind vs ls)) = ForAll (Bind vs (Or (map Literal ls)))++toLiterals :: Clause -> [Literal]+toLiterals (Clause (Bind _ ls)) = ls++----------------------------------------------------------------------+-- Problems++type Tag = String++data Kind = Axiom | Conjecture | Question deriving (Eq, Ord)++data Answer = Satisfiable | Unsatisfiable | NoAnswer NoAnswerReason+  deriving (Eq, Ord)++instance Show Answer where+  show Satisfiable = "Satisfiable"+  show Unsatisfiable = "Unsatisfiable"+  show (NoAnswer x) = show x++data NoAnswerReason = GaveUp | Timeout deriving (Eq, Ord, Show)++data Input a = Input+  { tag ::  Tag,+    kind :: Kind,+    what :: a }++type Problem a = [Input a]++instance Functor Input where+  fmap f x = x { what = f (what x) }++----------------------------------------------------------------------+-- Symbolic stuff++-- A universe of types with typecase+data TypeOf a where+  Form :: TypeOf Form+  Clause_ :: TypeOf Clause+  Term :: TypeOf Term+  Atomic :: TypeOf Atomic+  Signed :: (Symbolic a, Symbolic (Signed a)) => TypeOf (Signed a)+  Bind_ :: (Symbolic a, Symbolic (Bind a)) => TypeOf (Bind a)+  List :: (Symbolic a, Symbolic [a]) => TypeOf [a]+  Input_ :: (Symbolic a, Symbolic (Input a)) => TypeOf (Input a)+  CNF_ :: TypeOf CNF++class Symbolic a where+  typeOf :: a -> TypeOf a++instance Symbolic Form where typeOf _ = Form+instance Symbolic Clause where typeOf _ = Clause_+instance Symbolic Term where typeOf _ = Term+instance Symbolic Atomic where typeOf _ = Atomic+instance Symbolic a => Symbolic (Signed a) where typeOf _ = Signed+instance Symbolic a => Symbolic (Bind a) where typeOf _ = Bind_+instance Symbolic a => Symbolic [a] where typeOf _ = List+instance Symbolic a => Symbolic (Input a) where typeOf _ = Input_+instance Symbolic CNF where typeOf _ = CNF_++-- Generic representations of values.+data Rep a where+  Const :: !a -> Rep a+  Unary :: Symbolic a => (a -> b) -> a -> Rep b+  Binary :: (Symbolic a, Symbolic b) => (a -> b -> c) -> a -> b -> Rep c++-- This inline declaration is crucial so that+-- pattern-matching on a rep degenerates into typecase.+{-# INLINE rep #-}+rep :: Symbolic a => a -> Rep a+rep x =+  case typeOf x of+    Form -> rep' x+    Clause_ -> rep' x+    Term -> rep' x+    Atomic -> rep' x+    Signed -> rep' x+    Bind_ -> rep' x+    List -> rep' x+    Input_ -> rep' x+    CNF_ -> rep' x++-- Implementation of rep for all types+class Unpack a where+  rep' :: a -> Rep a++instance Unpack Form where+  rep' (Literal l) = Unary Literal l+  rep' (Not t) = Unary Not t+  rep' (And ts) = Unary And ts+  rep' (Or ts) = Unary Or ts+  rep' (Equiv t u) = Binary Equiv t u+  rep' (ForAll b) = Unary ForAll b+  rep' (Exists b) = Unary Exists b+  rep' (Connective c t u) = Binary (Connective c) t u++instance Unpack Clause where+  rep' (Clause ls) = Unary Clause ls++instance Unpack Term where+  rep' t@Var{} = Const t+  rep' (f :@: ts) = Unary (f :@:) ts++instance Unpack Atomic where+  rep' (t :=: u) = Binary (:=:) t u+  rep' (Tru p) = Unary Tru p++instance Symbolic a => Unpack (Signed a) where+  rep' (Pos x) = Unary Pos x+  rep' (Neg x) = Unary Neg x++instance Symbolic a => Unpack (Bind a) where+  rep' (Bind vs x) = Unary (Bind vs) x++instance Symbolic a => Unpack [a] where+  rep' [] = Const []+  rep' (x:xs) = Binary (:) x xs++instance Symbolic a => Unpack (Input a) where+  rep' (Input tag kind what) = Unary (Input tag kind) what++instance Unpack CNF where+  rep' (CNF ax conj s1 s2) =+    Binary (\ax' conj' -> CNF ax' conj' s1 s2) ax conj++-- Little generic strategies++{-# INLINE recursively #-}+recursively :: Symbolic a => (forall a. Symbolic a => a -> a) -> a -> a+recursively h t =+  case rep t of+    Const x -> x+    Unary f x -> f (h x)+    Binary f x y -> f (h x) (h y)++{-# INLINE recursivelyM #-}+recursivelyM :: (Monad m, Symbolic a) => (forall a. Symbolic a => a -> m a) -> a -> m a+recursivelyM h t =+  case rep t of+    Const x -> return x+    Unary f x -> liftM f (h x)+    Binary f x y -> liftM2 f (h x) (h y)++{-# INLINE collect #-}+collect :: (Symbolic a, Monoid b) => (forall a. Symbolic a => a -> b) -> a -> b+collect h t =+  case rep t of+    Const _x -> mempty+    Unary _f x -> h x+    Binary _f x y -> h x `mappend` h y++----------------------------------------------------------------------+-- Substitutions++type Subst = Map Variable Term++ids :: Subst+ids = Map.empty++(|=>) :: Variable -> Term -> Subst+v |=> x = Map.singleton v x++(|+|) :: Subst -> Subst -> Subst+(|+|) = Map.union++subst :: Symbolic a => Subst -> a -> a+subst s t =+  case typeOf t of+    Term -> term t+    Bind_ -> bind t+    _ -> generic t+  where+    term (Var x)+      | Just u <- Map.lookup x s = u+    term t = generic t++    bind :: Symbolic a => Bind a -> Bind a+    bind (Bind vs t) =+      Bind vs (subst (checkBinder vs (Map.filterWithKey (\x _ -> x `Set.member` vs) s)) t)++    generic :: Symbolic a => a -> a+    generic t = recursively (subst s) t++----------------------------------------------------------------------+-- Functions operating on symbolic terms++free :: Symbolic a => a -> Set Variable+free t+  | Term <- typeOf t,+    Var x <- t        = var x+  | Bind_ <- typeOf t = bind t+  | otherwise         = collect free t+  where+    var :: Variable -> Set Variable+    var x = Set.singleton x++    bind :: Symbolic a => Bind a -> Set Variable+    bind (Bind vs t) = free t Set.\\ vs++ground :: Symbolic a => a -> Bool+ground = Set.null . free++bind :: Symbolic a => a -> Bind a+bind x = Bind (free x) x++-- Helper function for collecting information from terms and binders.+termsAndBinders :: forall a b.+                   Symbolic a =>+                   (Term -> DList b) ->+                   (forall a. Symbolic a => Bind a -> [b]) ->+                   a -> [b]+termsAndBinders term bind = DList.toList . aux where+  aux :: Symbolic c => c -> DList b+  aux t =+    collect aux t `mplus`+    case typeOf t of+      Term -> term t+      Bind_ -> DList.fromList (bind t)+      _ -> mzero++names :: Symbolic a => a -> [Name]+names = usort . termsAndBinders term bind where+  term t = return (name t) `mappend` return (name (typ t))++  bind :: Symbolic a => Bind a -> [Name]+  bind (Bind vs _) = map name (Set.toList vs)++run :: Symbolic a => a -> (a -> NameM b) -> b+run x f = runNameM (names x) (f x)++types :: Symbolic a => a -> [Type]+types = usort . termsAndBinders term bind where+  term t = return (typ t)++  bind :: Symbolic a => Bind a -> [Type]+  bind (Bind vs _) = map typ (Set.toList vs)++types' :: Symbolic a => a -> [Type]+types' = filter (/= O) . types++terms :: Symbolic a => a -> [Term]+terms = usort . termsAndBinders term mempty where+  term t = return t++vars :: Symbolic a => a -> [Variable]+vars = usort . termsAndBinders term bind where+  term (Var x) = return x+  term _ = mempty++  bind :: Symbolic a => Bind a -> [Variable]+  bind (Bind vs _) = Set.toList vs++functions :: Symbolic a => a -> [Function]+functions = usort . termsAndBinders term mempty where+  term (f :@: _) = return f+  term _ = mempty++isFof :: Symbolic a => a -> Bool+isFof f = length (types' f) <= 1++uniqueNames :: Symbolic a => a -> NameM a+uniqueNames t = evalStateT (aux Map.empty t) (Map.fromList [(x, t) | x ::: t <- Set.toList (free t)])+  where aux :: Symbolic a => Subst -> a -> StateT (Map Name Type) NameM a+        aux s t =+          case typeOf t of+            Term -> term s t+            Bind_ -> bind s t+            _ -> generic s t++        term :: Subst -> Term -> StateT (Map Name Type) NameM Term+        term s t@(Var x) = do+          case Map.lookup x s of+            Nothing -> return t+            Just u -> return u+        term s t = generic s t++        bind :: Symbolic a => Subst -> Bind a -> StateT (Map Name Type) NameM (Bind a)+        bind s (Bind vs x) = do+          used <- get+          let (stale, fresh) = partition ((`Map.member` used) . lhs) (Set.toList vs)+              tuple (x ::: y) = (x, y)+          stale' <- sequence [ lift (newSymbol x t) | x ::: t <- stale ]+          put (used `Map.union` Map.fromList (map tuple (fresh ++ stale')))+          case stale of+            [] -> fmap (Bind vs) (aux s x)+            _ ->+              do+                let s' = Map.fromList [(x, Var y) | (x, y) <- stale `zip` stale'] `Map.union` s+                    vs' = Set.fromList (stale' ++ fresh)+                fmap (Bind vs') (aux s' x)++        generic :: Symbolic a => Subst -> a -> StateT (Map Name Type) NameM a+        generic s t = recursivelyM (aux s) t++-- Force a value.+force :: Symbolic a => a -> a+force x = rnf x `seq` x+  where rnf :: Symbolic a => a -> ()+        rnf x =+          case rep x of+            Const !_ -> ()+            Unary _ x -> rnf x+            Binary _ x y -> rnf x `seq` rnf y++-- Check that there aren't two nested binders binding the same variable+check :: Symbolic a => a -> a+check x | not debugging = x+        | check' (free x) x = x+        | otherwise = error "Form.check: invariant broken"+  where check' :: Symbolic a => Set Variable -> a -> Bool+        check' vars t =+          case typeOf t of+            Term -> term vars t+            Bind_ -> bind vars t+            _ -> generic vars t++        term :: Set Variable -> Term -> Bool+        term vars (Var x) = x `Set.member` vars+        term vars t = generic vars t++        bind :: Symbolic a => Set Variable -> Bind a -> Bool+        bind vars (Bind vs t) =+          Set.null (vs `Set.intersection` vars) &&+          check' (vs `Set.union` vars) t++        generic :: Symbolic a => Set Variable -> a -> Bool+        generic vars = getAll . collect (All . check' vars)++-- Check that a binder doesn't capture variables from a substitution.+checkBinder :: Set Variable -> Subst -> Subst+checkBinder vs s | not debugging = s+                 | Set.null (free (Map.elems s) `Set.intersection` vs) = s+                 | otherwise = error "Form.checkBinder: capturing substitution"++-- Apply a function to each name, while preserving sharing.+mapName :: Symbolic a => (Name -> Name) -> a -> a+mapName f0 = rename+  where+    rename :: Symbolic a => a -> a+    rename t =+      case typeOf t of+        Term -> term t+        Bind_ -> bind t+        _ -> recursively rename t++    bind :: Symbolic a => Bind a -> Bind a+    bind (Bind vs t) =  Bind (Set.map var vs) (rename t)+    term (f :@: ts) = fun f :@: map term ts+    term (Var x) = Var (var x)++    var = memo $ \(x ::: ty) -> f x ::: type_ ty+    fun = memo $ \(x ::: FunType args res) ->+                   f x ::: FunType (map type_ args) (type_ res)+    type_ =+      memo $ \ty ->+        case ty of+          O -> O+          Type name x y -> Type (f name) x y++    f = memo f0++-- Apply a function to each type, while preserving sharing.+mapType :: Symbolic a => (Type -> Type) -> a -> a+mapType f0 = mapType'+  where mapType' :: Symbolic a => a -> a+        mapType' t =+          case typeOf t of+            Term -> term t+            Bind_ -> bind t+            _ -> recursively mapType' t++        bind :: Symbolic a => Bind a -> Bind a+        bind (Bind vs t) = Bind (Set.map var vs) (mapType' t)++        term (f :@: ts) = fun f :@: map term ts+        term (Var x) = Var (var x)++        var = memo $ \(x ::: ty) -> x ::: f ty+        fun = memo $ \(x ::: FunType args res) ->+                       x ::: FunType (map f args) (f res)++        f = memo f0
+ src/Jukebox/GuessModel.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GADTs, PatternGuards #-}+module Jukebox.GuessModel where++import Control.Monad+import Jukebox.Name+import Jukebox.Form+import Jukebox.TPTP.Print+import Jukebox.TPTP.ParseSnippet+import Jukebox.Utils++data Universe = Peano | Trees++universe :: Universe -> Type -> NameM ([Function], [Form])+universe Peano = peano+universe Trees = trees++peano i = do+  zero <- newFunction "zero" [] i+  succ <- newFunction "succ" [i] i+  pred <- newFunction "pred" [i] i+  let types = [("$i", i)]+      funs = [("zero", zero),+              ("succ", succ),+              ("pred", pred)]+  +  let prelude =+        map (cnf types funs) [+          "zero != succ(X)",+          "pred(succ(X)) = X"+        ]+  return ([zero, succ], prelude)++trees i = do+  nil <- newFunction "nil" [] i+  bin <- newFunction "bin" [i, i] i+  left <- newFunction "left" [i] i+  right <- newFunction "right" [i] i+  let types = [("$i", i)]+      funs = [("nil", nil),+              ("bin", bin),+              ("left", left),+              ("right", right)]+  +  let prelude =+        map (cnf types funs) [+          "nil != bin(X,Y)",+          "left(bin(X,Y)) = X",+          "right(bin(X,Y)) = Y"+        ]+  return ([nil, bin], prelude)++guessModel :: [String] -> Universe -> Problem Form -> Problem Form+guessModel expansive univ prob = run prob $ \forms -> do+  let i = ind forms+  answerType <- newType "answer"+  answer <- newFunction "$answer" [answerType] O+  let withExpansive f func = f func (base (name func) `elem` expansive) answer+  (constructors, prelude) <- universe univ i+  program <- fmap concat (mapM (withExpansive (function constructors)) (functions forms))+  return (map (Input "adt" Axiom) prelude +++          map (Input "program" Axiom) program +++          forms)++ind :: Symbolic a => a -> Type+ind x =+  case types' x of+    [ty] -> ty+    [] -> Type (name "$i") Infinite Infinite+    _ -> error "GuessModel: can't deal with many-typed problems"++function :: [Function] -> Function -> Bool -> Function -> NameM [Form]+function constructors f expansive answerP = fmap concat $ do+  argss <- cases constructors (funArgs f)+  forM argss $ \args -> do+    fname <- newFunction ("exhausted_" ++ base (name f) ++ "_case")+               [] (head (funArgs answerP))+    let answer = Literal (Pos (Tru (answerP :@: [fname :@: []])))+    let theRhss = rhss constructors args f expansive answer+    alts <- forM theRhss $ \rhs -> do+      pred <- newFunction (concat (lines (prettyShow rhs))) [] O+      return (Literal (Pos (Tru (pred :@: []))))+    return $+      foldr (\/) false alts:+      [ closeForm (Connective Implies alt rhs)+      | (alt, rhs) <- zip alts theRhss ]++rhss :: [Function] -> [Term] -> Function -> Bool -> Form -> [Form]+rhss constructors args f expansive answer =+  case typ f of+    O ->+      Literal (Pos (Tru (f :@: args))):+      Literal (Neg (Tru (f :@: args))):+      map its (map (f :@:) (recursive args))+    _ | expansive -> map its (usort (unconditional ++ constructor))+      | otherwise -> map its (usort unconditional) ++ [answer]+  where recursive [] = []+        recursive (a:as) = reduce a ++ map (a:) (recursive as)+          where reduce (_f :@: xs) = [ x:as' | x <- xs, as' <- as:recursive as ]+                reduce _ = []+        constructor = [ c :@: xs+                      | c <- constructors,+                        xs <- sequence (replicate (arity c) unconditional) ]+        +        subterm = terms args+        its t = f :@: args .=. t+        unconditional = map (f :@:) (recursive args) ++ subterm++cases :: [Function] -> [Type] -> NameM [[Term]]+cases _constructors [] = return [[]]+cases constructors (ty:tys) = do+  ts <- cases1 constructors ty+  tss <- cases constructors tys+  return (liftM2 (:) ts tss)++cases1 :: [Function] -> Type -> NameM [Term]+cases1 constructors ty = do+  let maxArity = maximum (map arity constructors)+      varNames = take maxArity (cycle ["X", "Y", "Z"])+  vars <- mapM (flip newSymbol ty) varNames+  return [ c :@: take (arity c) (map Var vars)+         | c <- constructors ]
+ src/Jukebox/HighSat.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}+module Jukebox.HighSat where++import MiniSat hiding (neg)+import qualified MiniSat+import Jukebox.Form(Signed(..), neg)+import qualified Data.Map.Strict as Map+import Data.Map(Map)+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader+import Data.Maybe++newtype Sat1 a b = Sat1 { runSat1_ :: ReaderT Solver (ReaderT (Watch a) (StateT (Map a Lit) IO)) b } deriving (Functor, Applicative, Monad, MonadIO)+newtype Sat a b c = Sat { runSat_ :: ReaderT (Watch a) (StateT (Map b (SatState a)) IO) c } deriving (Functor, Applicative, Monad, MonadIO)+data SatState a = SatState Solver (Map a Lit)+type Watch a = a -> Sat1 a ()++data Form a+  = Lit (Signed a)+  | And [Form a]+  | Or [Form a]++nt :: Form a -> Form a+nt (Lit x) = Lit (neg x)+nt (And xs) = Or (fmap nt xs)+nt (Or xs) = And (fmap nt xs)++true, false :: Form a+true = And []+false = Or []++unique :: [Form a] -> Form a+unique = u+  where u [] = true+        u [_] = true+        u (x:xs) = And [Or [nt x, And (map nt xs)],+                        u xs]++runSat :: Ord b => Watch a -> [b] -> Sat a b c -> IO c+runSat w idxs x = go idxs Map.empty+  where go [] m = evalStateT (runReaderT (runSat_ x) w) m+        go (idx:idxs) m =+          withNewSolver $ \s -> go idxs (Map.insert idx (SatState s Map.empty) m)++runSat1 :: Ord a => Watch a -> Sat1 a b -> IO b+runSat1 w x = runSat w [()] (atIndex () x)++atIndex :: (Ord a, Ord b) => b -> Sat1 a c -> Sat a b c+atIndex !idx m = do+  watch <- Sat ask+  SatState s ls <- Sat (lift (gets (Map.findWithDefault (error "withSolver: index not found") idx)))+  (x, ls') <- liftIO (runStateT (runReaderT (runReaderT (runSat1_ m) s) watch) ls)+  Sat (lift (modify (Map.insert idx (SatState s ls'))))+  return x++solve :: Ord a => [Signed a] -> Sat1 a Bool+solve xs = do+  s <- Sat1 ask+  ls <- mapM lit xs+  liftIO (MiniSat.solve s ls)++model :: Ord a => Sat1 a (a -> Bool)+model = do+  s <- Sat1 ask+  m <- Sat1 (lift (lift get))+  vals <- liftIO (traverse (MiniSat.modelValue s) m)+  return (\v -> fromMaybe False (Map.findWithDefault Nothing v vals))++modelValue :: Ord a => a -> Sat1 a Bool+modelValue x = do+  s <- Sat1 ask+  l <- var x+  Just b <- liftIO (MiniSat.modelValue s l)+  return b++addForm :: Ord a => Form a -> Sat1 a ()+addForm f = do+  s <- Sat1 ask+  cs <- flatten f+  liftIO (mapM (MiniSat.addClause s) cs)+  return ()++flatten :: Ord a => Form a -> Sat1 a [[Lit]]+flatten (Lit l) = fmap (return . return) (lit l)+flatten (And fs) = fmap concat (mapM flatten fs)+flatten (Or fs) = fmap (fmap concat . sequence) (mapM flatten fs)++lit :: Ord a => Signed a -> Sat1 a Lit+lit (Pos x) = var x+lit (Neg x) = liftM MiniSat.neg (var x)++var :: Ord a => a -> Sat1 a Lit+var x = do+  s <- Sat1 ask+  m <- Sat1 (lift (lift get))+  case Map.lookup x m of+    Nothing -> do+      l <- liftIO (MiniSat.newLit s)+      Sat1 (lift (lift (put (Map.insert x l m))))+      w <- Sat1 (lift ask)+      w x+      return l+    Just l -> return l
+ src/Jukebox/InferTypes.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE TypeOperators, GADTs, CPP #-}+module Jukebox.InferTypes where++#include "errors.h"+import Control.Monad+import Jukebox.Form+import Jukebox.Name+import qualified Data.Map.Strict as Map+import Data.Map(Map)+import Jukebox.UnionFind hiding (rep)+import qualified Data.Set as Set+import Data.MemoUgly++type Function' = ([(Name, Type)], (Name, Type))++inferTypes :: [Input Clause] -> NameM ([Input Clause], Type -> Type)+inferTypes prob = do+  funMap <-+    fmap Map.fromList . sequence $+      [ do res <- newName (typ f)+           args <- mapM newName (funArgs f)+           return (name f,+                   (zipWith (,) args (funArgs f),+                    (res, typ f)))+      | f <- functions prob ]+  varMap <-+    fmap Map.fromList . sequence $+      [ do ty <- newName (typ v)+           return (name v, (ty, typ v))+      | v <- vars prob ]+  +  let tyMap = Map.fromList $+              concat [ res:args | (args, res) <- Map.elems funMap ] +++              [ ty | ty <- Map.elems varMap ]+  +  let (prob', rep) = solve funMap varMap prob+      rep' ty =+        Map.findWithDefault __ (rep (name ty)) tyMap+  +  return (prob', rep')++solve :: Map Name Function' -> Map Name (Name, Type) ->+         [Input Clause] -> ([Input Clause], Name -> Name)+solve funMap varMap prob = (prob', rep)+  where prob' = aux prob+        aux :: Symbolic a => a -> a+        aux t =+          case typeOf t of+            Bind_ -> bind t+            Term -> term t+            _ -> recursively aux t++        bind :: Symbolic a => Bind a -> Bind a+        bind (Bind vs t) = Bind (Set.map var vs) (aux t)++        term (f :@: ts) = fun f :@: map term ts+        term (Var x) = Var (var x)++        fun = memo fun_+        fun_ (f ::: _) =+          let (args, res) = Map.findWithDefault __ f funMap+          in f ::: FunType (map type_ args) (type_ res)++        var = memo var_+        var_ (x ::: _) = x ::: type_ (Map.findWithDefault __ x varMap)++        type_ = memo type__+        type__ (_, O) = O+        type__ (name, _) = Type (rep name) Infinite Infinite++        rep = evalUF initial $ do+          generate funMap varMap prob+          reps++generate :: Map Name Function' -> Map Name (Name, Type) -> [Input Clause] -> UF Name ()+generate funMap varMap cs = mapM_ (mapM_ atomic) lss+  where lss = map (map the . toLiterals . what) cs+        atomic (Tru p) = void (term p)+        atomic (t :=: u) = do { t' <- term t; u' <- term u; t' =:= u'; return () }+        term (Var x) = return y+          where (y, _) = Map.findWithDefault __ (name x) varMap+        term (f :@: xs) = do+          ys <- mapM term xs+          let (zs, r) = Map.findWithDefault __ (name f) funMap+          zipWithM_ (=:=) ys (map fst zs)+          return (fst r)
+ src/Jukebox/Monotonox/Monotonicity.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TypeOperators #-}+module Jukebox.Monotonox.Monotonicity where++import Prelude hiding (lookup)+import Jukebox.Name+import Jukebox.Form hiding (Form, clause, true, false, And, Or)+import Jukebox.HighSat+import Control.Monad+import qualified Data.Map.Strict as Map+import Data.Map(Map)++data Extension = TrueExtend | FalseExtend | CopyExtend deriving Show++data Var = FalseExtended Function | TrueExtended Function deriving (Eq, Ord)++annotateMonotonicity :: Problem Clause -> IO (Problem Clause)+annotateMonotonicity prob = do+  m <- monotone (map what prob)+  let f O = O+      f ty =+        case Map.lookup ty m of+          Nothing -> ty+          Just{} -> ty { tmonotone = Finite 0 }+  return (fmap (mapType f) prob)++monotone :: [Clause] -> IO (Map Type (Maybe (Map Function Extension)))+monotone cs = runSat watch tys $ do+  let fs = functions cs+  mapM_ (clause . toLiterals) cs+  fmap Map.fromList . forM tys $ \ty -> atIndex ty $ do+    r <- solve []+    case r of+      False -> return (ty, Nothing)+      True -> do+        m <- model+        return (ty, Just (fromModel fs ty m))+  where watch (FalseExtended f) =+          addForm (Or [Lit (Neg (FalseExtended f)),+                       Lit (Neg (TrueExtended f))])+        watch _ = return ()+        tys = types' cs++fromModel :: [Function] -> Type -> (Var -> Bool) -> Map Function Extension+fromModel fs ty m = Map.fromList [ (f, extension f m) | f <- fs, typ f == O, ty `elem` args (rhs f) ]++extension :: Function -> (Var -> Bool) -> Extension+extension f m =+  case (m (FalseExtended f), m (TrueExtended f)) of+    (False, False) -> CopyExtend+    (True, False) -> FalseExtend+    (False, True) -> TrueExtend++clause :: [Literal] -> Sat Var Type ()+clause ls = mapM_ (literal ls) ls++literal :: [Literal] -> Literal -> Sat Var Type ()+literal ls (Pos (t :=: u)) = atIndex (typ t) $ do+  addForm (safe ls t)+  addForm (safe ls u)+literal _ls (Neg (_ :=: _)) = return ()+literal ls (Pos (Tru (p :@: ts))) =+  forM_ ts $ \t -> atIndex (typ t) $ addForm (Or [safe ls t, Lit (Neg (FalseExtended p))])+literal ls (Neg (Tru (p :@: ts))) =+  forM_ ts $ \t -> atIndex (typ t) $ addForm (Or [safe ls t, Lit (Neg (TrueExtended p))])++safe :: [Literal] -> Term -> Form Var+safe ls (Var x) = Or [ guards l x | l <- ls ]+safe _ _ = true++guards :: Literal -> Variable -> Form Var+guards (Neg (Var _ :=: Var _)) _ = error "Monotonicity.guards: found a variable inequality X!=Y after clausification"+guards (Neg (Var x :=: _)) y | x == y = true+guards (Neg (_ :=: Var x)) y | x == y = true+guards (Pos (Tru (p :@: ts))) x | Var x `elem` ts = Lit (Pos (TrueExtended p))+guards (Neg (Tru (p :@: ts))) x | Var x `elem` ts = Lit (Pos (FalseExtended p))+guards _ _ = false
+ src/Jukebox/Monotonox/ToFOF.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE GADTs, PatternGuards #-}+module Jukebox.Monotonox.ToFOF where++import Jukebox.Clausify(split, removeEquiv, run, withName)+import Jukebox.Name+import Jukebox.Form hiding (run)+import qualified Jukebox.Form as Form+import Jukebox.Options+import Control.Monad hiding (guard)+import Data.Monoid+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++data Scheme = Scheme {+  makeFunction :: Type -> NameM Function,+  scheme1 :: (Type -> Bool) -> (Type -> Function) -> Scheme1+  }++data Scheme1 = Scheme1 {+  forAll :: Bind Form -> Form,+  exists :: Bind Form -> Form,+  equals :: Term -> Term -> Form,+  funcAxiom :: Function -> NameM Form,+  typeAxiom :: Type -> NameM Form+  }++guard :: Scheme1 -> (Type -> Bool) -> Input Form -> Input Form+guard scheme mono (Input t k f) = Input t k (aux (pos k) f)+  where aux pos (ForAll (Bind vs f))+          | pos = forAll scheme (Bind vs (aux pos f))+          | otherwise = Not (exists scheme (Bind vs (Not (aux pos f))))+        aux pos (Exists (Bind vs f))+          | pos = exists scheme (Bind vs (aux pos f))+          | otherwise = Not (forAll scheme (Bind vs (Not (aux pos f))))+        aux _pos (Literal (Pos (t :=: u)))+          | not (mono (typ t)) = equals scheme t u+        aux _pos (Literal (Neg (t :=: u)))+          | not (mono (typ t)) = Not (equals scheme t u)+        aux _pos l@Literal{} = l+        aux pos (Not f) = Not (aux (not pos) f)+        aux pos (And fs) = And (fmap (aux pos) fs)+        aux pos (Or fs) = Or (fmap (aux pos) fs)+        aux _pos (Equiv _ _) = error "ToFOF.guard: equiv should have been eliminated"+        aux _pos (Connective _ _ _) = error "ToFOF.guard: connective should have been eliminated"+        pos Axiom = True+        pos Conjecture = False++translate, translate1 :: Scheme -> (Type -> Bool) -> Problem Form -> Problem Form+translate1 scheme mono f = Form.run f $ \inps -> do+  let tys = types' inps+      funcs = functions inps+      -- Hardly any use adding guards if there's only one type.+      mono' | length tys == 1 = const True+            | otherwise = mono+  typeFuncs <- mapM (makeFunction scheme) tys+  let typeMap = Map.fromList (zip tys typeFuncs)+      lookupType ty =+        case Map.lookup ty typeMap of+          Just f -> f+          Nothing -> error "ToFOF.translate: type not found"+      scheme1' = scheme1 scheme mono' lookupType+  funcAxioms <- mapM (funcAxiom scheme1') funcs+  typeAxioms <- mapM (typeAxiom scheme1') tys+  let axioms =+        map (simplify . ForAll . bind) . split . simplify . foldr (/\) true $+          funcAxioms ++ typeAxioms+  return $+    [ Input ("types" ++ show i) Axiom axiom | (axiom, i) <- zip axioms [1..] ] +++    map (guard scheme1' mono') inps++translate scheme mono f =+  let f' =+        Form.run f $ \inps -> do+          forM inps $ \(Input tag kind f) -> do+            let prepare f = fmap (foldr (/\) true) (run (withName tag (removeEquiv (simplify f))))+            fmap (Input tag kind) $+              case kind of+                Axiom -> prepare f+                Conjecture -> fmap notInwards (prepare (nt f))+      typeI = Type (name "$i") (Finite 0) Infinite+  in Form.run (translate1 scheme mono f') (return . mapType (const typeI))++-- Typing functions.++tagsFlags :: OptionParser Bool+tagsFlags =+  bool "more-axioms"+    ["Add extra typing axioms for function arguments,",+     "when using typing tags.",+     "These are unnecessary for completeness but may help (or hinder!) the prover."]++tags :: Bool -> Scheme+tags moreAxioms = Scheme+  { makeFunction = \ty ->+      newFunction ("to_" ++ base ty) [ty] ty,+    scheme1 = tags1 moreAxioms }++tags1 :: Bool -> (Type -> Bool) -> (Type -> Function) -> Scheme1+tags1 moreAxioms mono fs = Scheme1+  { forAll = ForAll,+    exists = \(Bind vs f) ->+       let bound = foldr (/\) true (map guard (Set.toList vs))+           guard v | mono (typ v) = true+                   | otherwise = Literal (Pos (fs (typ v) :@: [Var v] :=: Var v))+       in Exists (Bind vs (simplify bound /\ f)),+    equals =+      \t u ->+        let protect t@Var{} = fs (typ t) :@: [t]+            protect t = t+        in Literal (Pos (protect t :=: protect u)),+    funcAxiom = tagsAxiom moreAxioms mono fs,+    typeAxiom = \ty -> if moreAxioms then tagsAxiom False mono fs (fs ty) else tagsExists mono ty (fs ty) }++tagsAxiom :: Bool -> (Type -> Bool) -> (Type -> Function) -> Function -> NameM Form+tagsAxiom moreAxioms mono fs f@(_ ::: FunType args _res) = do+  vs <- forM args $ \ty ->+    fmap Var (newSymbol "X" ty)+  let t = f :@: vs+      at n f xs = take n xs ++ [f (xs !! n)] ++ drop (n+1) xs+      tag t = fs (typ t) :@: [t]+      equate (ty, t') | mono ty = true+                      | otherwise = t `eq` t'+      t `eq` u | typ t == O = Literal (Pos (Tru t)) `Equiv` Literal (Pos (Tru u))+               | otherwise = Literal (Pos (t :=: u))+      ts = (typ t, tag t):+           [ (typ (vs !! n), f :@: at n tag vs)+           | moreAxioms,+             n <- [0..length vs-1] ]+  return (foldr (/\) true (map equate ts))++tagsExists :: (Type -> Bool) -> Type -> Function -> NameM Form+tagsExists mono ty f+  | mono ty = return true+  | otherwise = do+      v <- fmap Var (newSymbol "X" ty)+      return (Exists (bind (Literal (Pos (f :@: [v] :=: v)))))++-- Typing predicates.++guards :: Scheme+guards = Scheme+  { makeFunction = \ty ->+      newFunction ("is_" ++ base ty) [ty] O,+    scheme1 = guards1 }++guards1 :: (Type -> Bool) -> (Type -> Function) -> Scheme1+guards1 mono ps = Scheme1+  { forAll = \(Bind vs f) ->+       let bound = foldr (/\) true (map guard (Set.toList vs))+           guard v | mono (typ v) = true+                   | not (naked True v f) = true+                   | otherwise = Literal (Pos (Tru (ps (typ v) :@: [Var v])))+       in ForAll (Bind vs (simplify (Not bound) \/ f)),+    exists = \(Bind vs f) ->+       let bound = foldr (/\) true (map guard (Set.toList vs))+           guard v | mono (typ v) = true+--                   | not (naked True v f) = true+                   | otherwise = Literal (Pos (Tru (ps (typ v) :@: [Var v])))+       in Exists (Bind vs (simplify bound /\ f)),+    equals = \t u -> Literal (Pos (t :=: u)),+    funcAxiom = guardsAxiom mono ps,+    typeAxiom = guardsTypeAxiom mono ps }++naked :: Symbolic a => Bool -> Variable -> a -> Bool+naked pos v f+  | Form <- typeOf f,+    Not f' <- f = naked (not pos) v f'+  | Signed <- typeOf f,+    Pos f' <- f = naked pos v f'+  | Signed <- typeOf f,+    Neg f' <- f = naked (not pos) v f'+  | Atomic <- typeOf f,+    t :=: u <- f,+    pos = t == Var v || u == Var v+  | Bind_ <- typeOf f,+    Bind vs f' <- f = not (Set.member v vs) && naked pos v f'+  | otherwise = getAny (collect (Any . naked pos v) f)++guardsAxiom :: (Type -> Bool) -> (Type -> Function) -> Function -> NameM Form+guardsAxiom mono ps f@(_ ::: FunType args res)+  | mono res = return true+  | otherwise = do+    vs <- forM args $ \ty ->+      fmap Var (newSymbol "X" ty)+    return (Literal (Pos (Tru (ps res :@: [f :@: vs]))))++guardsTypeAxiom :: (Type -> Bool) -> (Type -> Function) -> Type -> NameM Form+guardsTypeAxiom mono ps ty+  | mono ty = return true+  | otherwise = do+    v <- fmap Var (newSymbol "X" ty)+    return (Exists (bind (Literal (Pos (Tru (ps ty :@: [v]))))))
+ src/Jukebox/Name.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving, FlexibleInstances #-}+module Jukebox.Name where++import Control.Monad+import Control.Monad.Trans.State.Strict+import Data.Ord+import Data.Int+import Data.Symbol+import Data.Char++data Name =+    Fixed {-# UNPACK #-} !Symbol+  | Unique {-# UNPACK #-} !Int64 String Renamer++type Renamer = String -> Int -> Renaming+data Renaming = Renaming [String] String++base :: Named a => a -> String+base x =+  case name x of+    Fixed xs -> unintern xs+    Unique _ xs _ -> xs++renamer :: Named a => a -> Renamer+renamer x =+  case name x of+    Fixed _ -> defaultRenamer+    Unique _ _ f -> f++defaultRenamer :: Renamer+defaultRenamer xs 0 = Renaming [] xs+defaultRenamer xs n = Renaming [] $ xs ++ sep ++ show (n+1)+  where+    sep+      | not (null xs) && isDigit (last xs) = "_"+      | otherwise = ""++withRenamer :: Name -> Renamer -> Name+Fixed x `withRenamer` _ = Fixed x+Unique n xs _ `withRenamer` f = Unique n xs f++instance Eq Name where+  x == y = compareName x == compareName y++instance Ord Name where+  compare = comparing compareName++compareName :: Name -> Either Symbol Int64+compareName (Fixed xs) = Left xs+compareName (Unique n _ _) = Right n++instance Show Name where+  show (Fixed xs) = unintern xs+  show (Unique n xs f) = ys ++ "@" ++ show n+    where+      Renaming _ ys = f xs 0++class Named a where+  name :: a -> Name++instance Named [Char] where+  name = Fixed . intern++instance Named Name where+  name = id++data a ::: b = a ::: b deriving Show++lhs :: (a ::: b) -> a+lhs (x ::: _) = x++rhs :: (a ::: b) -> b+rhs (_ ::: y) = y++instance Named a => Eq (a ::: b) where s == t = name s == name t+instance Named a => Ord (a ::: b) where compare = comparing name++instance Named a => Named (a ::: b) where+  name (a ::: _) = name a++newtype NameM a =+  NameM { unNameM :: State Int64 a }+    deriving (Functor, Applicative, Monad)++runNameM :: [Name] -> NameM a -> a+runNameM xs m =+  evalState (unNameM m) (maximum (0:[ succ n | Unique n _ _ <- xs ]))++newName :: Named a => a -> NameM Name+newName x = NameM $ do+  idx <- get+  let idx' = idx+1+  when (idx' < 0) $ error "Name.newName: too many names"+  put $! idx'+  return $! Unique idx' (base x) (renamer x)
+ src/Jukebox/Options.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE FlexibleContexts #-}+module Jukebox.Options where++import Control.Arrow((***))+import Control.Monad(mplus)+import Data.Char+import Data.List+import System.Environment+import System.Exit+import System.IO++----------------------------------------------------------------------+-- A parser of some kind annotated with a help text of some kind+data Annotated d p a = Annotated+  { descr :: d,+    parser :: p a }++instance Functor p => Functor (Annotated d p) where+  fmap f (Annotated d x) = Annotated d (fmap f x)++instance (Monoid d, Applicative p) => Applicative (Annotated d p) where+  pure = Annotated mempty . pure+  Annotated d f <*> Annotated d' x =+    Annotated (d `mappend` d') (f <*> x)++instance (Monoid d, Monoid (p a)) => Monoid (Annotated d p a) where+  mempty = Annotated mempty mempty+  Annotated d p `mappend` Annotated d' p' =+    Annotated (d `mappend` d') (p `mappend` p')++----------------------------------------------------------------------+-- Parsing of single arguments (e.g. integers)+-- and single flags (e.g. --verbosity 3).++type ArgParser = Annotated ArgDesc SeqParser+type ArgDesc = String -- description, e.g. "<number>"++-- Called SeqParser because <*> is sequential composition.+data SeqParser a = SeqParser+  { args :: Int, -- How many arguments will be consumed+    consume :: [String] -> Either Error a }++instance Functor SeqParser where+  fmap f (SeqParser a c) = SeqParser a (fmap f . c)++instance Applicative SeqParser where+  pure = SeqParser 0 . const . pure+  SeqParser a c <*> SeqParser a' c' = SeqParser (a + a') f+    where f xs = c xs <*> c' (drop a xs)++arg :: ArgDesc -> String -> (String -> Maybe a) -> ArgParser a+arg desc err f = Annotated desc (SeqParser 1 c)+  where c [] = Left (Mistake err)+        c (x:_) | "--" `isPrefixOf` x = Left (Mistake err)+        c (x:_) =+          case f x of+            Nothing -> Left (Mistake err)+            Just ok -> Right ok++argNum :: (Read a, Num a) => ArgParser a+argNum = arg "<num>" "expected a number" f+  where f x =+          case reads x of+            [(y, "")] -> Just y+            _ -> Nothing++argFile :: ArgParser FilePath+argFile = arg "<file>" "expected a file" Just++argFiles :: ArgParser [FilePath]+argFiles = arg "<files>" "expected a list of files" $ \x ->+  Just $ elts $ x ++ ","+  where+    elts [] = []+    elts s  = w:elts r+      where+        w = takeWhile (/= ',') s+        r = tail (dropWhile (/= ',') s)++argName :: ArgParser FilePath+argName = arg "<name>" "expected a name" Just++argNums :: ArgParser [Int]+argNums = arg "<nums>" "expected a number list" $ \x ->+  nums . groupBy (\x y -> isDigit x == isDigit y) $ x ++ ","+  where+    nums []                = Just []+    nums (n:",":ns)        = (read n :) `fmap` nums ns+    nums (n:"..":m:",":ns) = ([read n .. read m] ++) `fmap` nums ns+    nums _                 = Nothing++argOption :: [String] -> ArgParser String+argOption as = arg ("<" ++ concat (intersperse " | " as) ++ ">") "expected an argument" elts+  where+    elts x | x `elem` as = Just x+           | otherwise   = Nothing++argList :: [String] -> ArgParser [String]+argList as = arg ("<" ++ concat (intersperse " | " as) ++ ">*") "expected an argument" $ \x ->+  elts $ x ++ ","+  where+    elts []              = Just []+    elts s | w `elem` as = (w:) `fmap` elts r+      where+        w = takeWhile (/= ',') s+        r = tail (dropWhile (/= ',') s)+    +    elts _ = Nothing++-- A parser that always fails but produces an error message (useful for --help etc.)+argUsage :: ExitCode -> [String] -> ArgParser a+argUsage code err = Annotated [] (SeqParser 0 (const (Left (Usage code err))))++----------------------------------------------------------------------+-- Parsing of whole command lines.++type OptionParser = Annotated [Flag] ParParser++-- Called ParParser because <*> is parallel composition.+-- In other words, in f <*> x, f and x both see the whole command line.+-- We want this when parsing command lines because+-- it doesn't matter what order we write the options in.+data ParParser a = ParParser+  { val :: IO a, -- impure so we can put system information in our options records+    peek :: [String] -> ParseResult a }++data ParseResult a+    -- Yes n x: consumed n arguments, continue parsing with x+  = Yes Int (ParParser a)+    -- No x: didn't understand this flag, continue parsing with x+  | No (ParParser a)+    -- Error+  | Error Error++data Error =+    Mistake String+  | Usage ExitCode [String]++instance Functor ParParser where+  fmap f x = pure f <*> x++instance Applicative ParParser where+  pure x = ParParser (return x) (const (pure x))+  ParParser v p <*> ParParser v' p' =+    ParParser (v <*> v') (\xs -> p xs <*> p' xs)++instance Functor ParseResult where+  fmap f x = pure f <*> x++instance Applicative ParseResult where+  pure = No . pure+  Yes n r <*> Yes n' r'+    | n == n' = Yes n (r <*> r')+    | otherwise = error "Options.ParseResult: inconsistent number of arguments"+  Error s <*> _ = Error s+  _ <*> Error s = Error s+  Yes n r <*> No x = Yes n (r <*> x)+  No x <*> Yes n r = Yes n (x <*> r)+  No f <*> No x = No (f <*> x)++runPar :: ParParser a -> [String] -> Either Error (IO a)+runPar p [] = Right (val p)+runPar p xs@(x:_) =+  case peek p xs of+    Yes n p' -> runPar p' (drop n xs)+    No _ -> Left (Mistake ("Didn't recognise option " ++ x))+    Error err -> Left err++awaitP :: (String -> Bool) -> a -> (String -> [String] -> ParseResult a) -> ParParser a+awaitP p def par = ParParser (return def) f+  where f (x:xs) | p x =+          case par x xs of+            Yes n r -> Yes (n+1) r+            No _ ->+              error "Options.await: got No"+            Error err -> Error err+        f _ = No (awaitP p def par)++await :: String -> a -> ([String] -> ParseResult a) -> ParParser a+await flag def f = awaitP (\x -> "--" ++ flag == x) def (const f)++data Flag = Flag+  { flagName :: String,+    flagGroup :: String,+    flagHelp :: [String],+    flagArgs :: String } deriving (Eq, Show)++-- From a flag name and and argument parser, produce an OptionParser.+flag :: String -> [String] -> a -> ArgParser a -> OptionParser a+flag name help def (Annotated desc (SeqParser args f)) =+  Annotated [desc'] (await name def g)+  where desc' = Flag name "Common options" help desc+        g xs =+          case f xs of+            Left (Mistake err) -> Error (Mistake ("Error in option --" ++ name ++ ": " ++ err))+            Left (Usage code err) -> Error (Usage code err)+            Right y -> Yes args (pure y <* noFlag)+        -- Give an error if the flag is repeated.+        noFlag =+          await name ()+            (const (Error (Mistake ("Option --" ++ name ++ " occurred twice"))))++manyFlags :: String -> [String] -> ArgParser a -> OptionParser [a]+manyFlags name help (Annotated desc (SeqParser args f)) =+  fmap reverse (Annotated [desc'] (go []))+  where desc' = Flag name "Common options" help desc+        go xs = await name xs (g xs)+        g xs ys =+          case f ys of+            Left (Mistake err) -> Error (Mistake ("Error in option --" ++ name ++ ": " ++ err))+            Left (Usage code err) -> Error (Usage code err)+            Right x -> Yes args (go (x:xs))++-- Read filenames from the command line.+filenames :: OptionParser [String]+filenames = Annotated [] (from [])+  where from xs = awaitP p xs (f xs)+        p x = not ("--" `isPrefixOf` x)+        f xs y _ = Yes 0 (from (xs ++ [y]))++-- Take a value from the environment.+io :: IO a -> OptionParser a+io m = Annotated [] p+  where p = ParParser m (const (No p))++-- A boolean flag.+bool :: String -> [String] -> OptionParser Bool+bool name help = flag name help False (pure True)++inGroup :: String -> OptionParser a -> OptionParser a+inGroup x (Annotated fls f) = Annotated [fl{ flagGroup = x } | fl <- fls] f++----------------------------------------------------------------------+-- Selecting a particular tool.++type ToolParser = Annotated [Tool] PrefixParser+data Tool = Tool+  { toolProgName :: String,+    toolName :: String,+    toolVersion :: String,+    toolHelp :: String }++newtype PrefixParser a = PrefixParser (String -> Maybe (Tool, ParParser a))++instance Functor PrefixParser where+  fmap f (PrefixParser g) = PrefixParser (fmap (id *** fmap f) . g)++instance Monoid (PrefixParser a) where+  mempty = PrefixParser (const Nothing)+  PrefixParser f `mappend` PrefixParser g =+    PrefixParser (\xs -> f xs `mplus` g xs)++runPref :: PrefixParser a -> [String] -> Either Error (IO a)+runPref _ [] = Left (Mistake "Expected a tool name")+runPref (PrefixParser f) (x:xs) =+  case f x of+    Nothing -> Left (Mistake ("No such tool " ++ x))+    Just (t, p) ->+      case runPar p xs of+        Left (Mistake x) -> Left (Usage (ExitFailure 1) (argError t x))+        Left (Usage code x) -> Left (Usage code x)+        Right x -> Right x++tool :: Tool -> OptionParser a -> ToolParser a+tool t p =+  Annotated [t] (PrefixParser f)+  where f x | x == toolProgName t = Just (t, parser p')+        f _ = Nothing+        p' = p <* versionParser <* helpParser+        helpParser = flag "help" ["Show this help text."] () (argUsage ExitSuccess (help t p'))+        versionParser = flag "version" ["Print the version number."] () (argUsage ExitSuccess [greeting t])++-- Use the program name as a tool name if possible.+getEffectiveArgs :: ToolParser a -> IO [String]+getEffectiveArgs (Annotated tools _) = do+  progName <-+    case tools of+      [tool] -> return (toolProgName tool)+      _ -> getProgName+  args <- getArgs+  if progName `elem` map toolProgName tools+    then return (progName:args)+    else return args++parseCommandLine :: Tool -> ToolParser a -> IO a+parseCommandLine t p = do+  let p' =+        case p of+          Annotated [_] _ -> p+          _ -> versionTool t `mappend` helpTool t p `mappend` p+  args <- getEffectiveArgs p'+  case runPref (parser p') args of+    Left (Mistake err) -> printHelp (ExitFailure 1) (argError t err)+    Left (Usage code err) -> printHelp code err+    Right x -> x++----------------------------------------------------------------------+-- Help screens.++printHelp :: ExitCode -> [String] -> IO a+printHelp code xs = do+  mapM_ (hPutStrLn stderr ) xs+  exitWith code++argError :: Tool -> String -> [String]+argError t err = [+  greeting t,+  err ++ ". Try --help."+  ]++usageTool :: Tool -> String -> [String] -> String -> ToolParser a+usageTool t0 flag msg bit = tool (Tool flag' flag' flag' "0") p+  where p = Annotated [] (ParParser (printHelp ExitSuccess msg)+                                    (const (Error (Usage (ExitFailure 1) msg'))))+        flag' = "--" ++ flag+        msg' = [+          greeting t0,+          "Didn't expect any arguments after " ++ flag' ++ ".",+          "Try " ++ toolProgName t0 ++ " <toolname> " ++ flag' ++ " if you want " ++ bit ++ " a particular tool."+          ]++versionTool :: Tool -> ToolParser a+versionTool t0 = usageTool t0 "version" [greeting t0] "the version of"++helpTool :: Tool -> ToolParser a -> ToolParser a+helpTool t0 p = usageTool t0 "help" help "help for"+  where help = concat [+          [greeting t0],+          usage t0 "<toolname> ",+          ["<toolname> can be any of the following:"],+          concat [ justify (toolProgName t) [toolHelp t] | t <- descr p ],+          ["", "Use " ++ toolProgName t0 ++ " <toolname> --help for help on a particular tool."]+          ]++help :: Tool -> OptionParser a -> [String]+help t p = concat [+  [greeting t],+  usage t "",+  ["<option> can be any of the following:"],+  concat [ justify ("--" ++ flagName f ++ " " ++ flagArgs f) (flagHelp f) | f <- nub (descr p) ]+  ]++greeting :: Tool -> String+greeting t = toolName t ++ ", version " ++ toolVersion t ++ "."++usage :: Tool -> String -> [String]+usage t opts = [+  "Usage: " ++ toolProgName t ++ " " ++ opts ++ "<option>* <file>*",+  toolHelp t ++ ".",+  "",+  "<file> should be in TPTP format.",+  ""+  ]++justify :: String -> [String] -> [String]+justify name help = ["", "  " ++ name] ++ map ("    " ++) help
+ src/Jukebox/Provers/E.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE GADTs #-}+module Jukebox.Provers.E where++import Jukebox.Form hiding (tag, Or)+import Jukebox.Name+import Jukebox.Options+import Control.Applicative hiding (Const)+import Control.Monad+import Jukebox.Utils+import Jukebox.TPTP.Parsec hiding (run)+import Jukebox.TPTP.Parse.Core hiding (newFunction, Term)+import Jukebox.TPTP.Print+import Jukebox.TPTP.Lexer hiding (Normal, keyword, Axiom, Var)+import Data.Maybe+import qualified Data.Map.Strict as Map+import Data.Map(Map)++data EFlags = EFlags {+  eprover :: String,+  timeout :: Maybe Int,+  memory :: Maybe Int+  }++eflags =+  inGroup "E prover options" $+  EFlags <$>+    flag "eprover"+      ["Path to the E theorem prover.",+       "Default: eprover"]+      "eprover"+      argFile <*>+    flag "timeout"+      ["Timeout for E, in seconds.",+       "Default: (off)"]+      Nothing+      (fmap Just argNum) <*>+    flag "memory"+      ["Memory limit for E, in megabytes.",+       "Default: (off)"]+      Nothing+      (fmap Just argNum)++-- Work around bug in E answer coding.+mangleAnswer :: Symbolic a => a -> NameM a+mangleAnswer t =+  case typeOf t of+    Term -> term t+    _ -> recursivelyM mangleAnswer t+  where term (f :@: [t]) | base f == "$answer" = do+          wrap <- newFunction "answer" [typ t] (head (funArgs f))+          return (f :@: [wrap :@: [t]])+        term t = recursivelyM mangleAnswer t++runE :: EFlags -> Problem Form -> IO (Either Answer [Term])+runE flags prob+  | not (isFof prob) = error "runE: E doesn't support many-typed problems"+  | otherwise = do+    (_code, str) <- popen (eprover flags) eflags+                   (showProblem (run prob mangleAnswer))+    return (extractAnswer prob str)+  where eflags = [ "--soft-cpu-limit=" ++ show n | Just n <- [timeout flags] ] +++                 ["--memory-limit=" ++ show n | Just n <- [memory flags] ] +++                 ["--tstp-in", "--tstp-out", "-tAuto", "-xAuto"] +++                 ["-l", "0"]++extractAnswer :: Symbolic a => a -> String -> Either Answer [Term]+extractAnswer prob str = fromMaybe (Left status) (fmap Right answer)+  where varMap = Map.fromList [(show (name x), x) | x <- vars prob]+        funMap = Map.fromList [(show (name x), x) | x <- functions prob]+        result = lines str+        status = head $+          [Satisfiable | "# SZS status Satisfiable" <- result] +++          [Satisfiable | "# SZS status CounterSatisfiable" <- result] +++          [Unsatisfiable | "# SZS status Unsatisfiable" <- result] +++          [Unsatisfiable | "# SZS status Theorem" <- result] +++          [NoAnswer Timeout | "# SZS status ResourceOut" <- result] +++          [NoAnswer Timeout | "# SZS status Timeout" <- result] +++          [NoAnswer Timeout | "# SZS status MemyOut" <- result] +++          [NoAnswer GaveUp]+        answer = listToMaybe $+          [ parse xs+          | line <- result+          , let prefix = "# SZS answers Tuple ["+                suffix = "|_]"+                (prefix', mid) = splitAt (length prefix) line+                (xs, suffix') = splitAt (length mid - length suffix) mid+          , prefix == prefix'+          , suffix == suffix' ]+        parse xs =+          let toks = scan xs+          in case run_ parser (UserState initialState toks) of+            Ok _ ts -> ts+            _ -> error "runE: couldn't parse result from E"+        parser =+          parens (bracks term `sepBy1` punct Or)+          <|> fmap (:[]) (bracks term)+        term =+          fmap (Var . lookup varMap) variable <|>+          liftM2 (:@:) (fmap (lookup funMap) atom) terms+        terms =+          bracks (term `sepBy1` punct Comma)+          <|> return []+        lookup :: Ord a => Map String a -> String -> a+        lookup m x = Map.findWithDefault (error "runE: result from E mentions free names") x m
+ src/Jukebox/Provers/SPASS.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE GADTs #-}+module Jukebox.Provers.SPASS where++import Jukebox.Form hiding (tag, Or)+import Jukebox.Options+import Jukebox.Utils+import Jukebox.TPTP.Print++data SPASSFlags =+  SPASSFlags {+    spass   :: String,+    timeout :: Maybe Int,+    sos     :: Bool }++spassFlags =+  inGroup "SPASS prover options" $+  SPASSFlags <$>+    flag "spass"+      ["Path to SPASS.",+       "Default: SPASS"]+      "SPASS"+      argFile <*>+    flag "timeout"+      ["Timeout in seconds.",+       "Default: (none)"]+      Nothing+      (fmap Just argNum) <*>+    flag "sos"+      ["Use set-of-support strategy.",+       "Default: false"]+      False+      (pure True)++runSPASS :: SPASSFlags -> Problem Form -> IO Answer+runSPASS flags prob+  | not (isFof prob) = error "runSPASS: SPASS doesn't support many-typed problems"+  | otherwise = do+    (_code, str) <- popen (spass flags) spassFlags (showProblem prob)+    return (extractAnswer str)+  where+    spassFlags =+      ["-TimeLimit=" ++ show n | Just n <- [timeout flags] ] +++      ["-SOS" | sos flags] +++      ["-TPTP", "-Stdin"]++extractAnswer :: String -> Answer+extractAnswer result =+  head $+    [ Unsatisfiable    | "SPASS beiseite: Proof found." <- lines result ] +++    [ Satisfiable      | "SPASS beiseite: Completion found." <- lines result ] +++    [ NoAnswer Timeout ]
+ src/Jukebox/Sat.hs view
@@ -0,0 +1,70 @@+module Jukebox.Sat+  ( Solver+  , newSolver+  , deleteSolver+  , Lit, neg+  , false, true+  +  , SatSolver(..)+  , newLit+  , addClause+  , solve+  , conflict+  , modelValue+  , value+  )+ where++--------------------------------------------------------------------------------++import MiniSat+  ( Solver+  , deleteSolver+  , Lit(..)+  , neg+  )++import qualified MiniSat as M++--------------------------------------------------------------------------------++false, true :: Lit+true  = MkLit 0+false = neg true++newSolver :: IO Solver+newSolver =+  do s <- M.newSolver+     x <- M.newLit s+     if x == false || x == true+       then do M.addClause s [true]+               return s+       else do error "failed to initialize false and true!"++--------------------------------------------------------------------------------++class SatSolver s where+  getSolver :: s -> Solver++instance SatSolver Solver where+  getSolver s = s++newLit :: SatSolver s => s -> IO Lit+newLit s = M.newLit (getSolver s)++addClause :: SatSolver s => s -> [Lit] -> IO ()+addClause s xs = M.addClause (getSolver s) xs >> return ()++solve :: SatSolver s => s -> [Lit] -> IO Bool+solve s xs = M.solve (getSolver s) xs++conflict :: SatSolver s => s -> IO [Lit]+conflict s = M.conflict (getSolver s)++modelValue :: SatSolver s => s -> Lit -> IO (Maybe Bool)+modelValue s x = M.modelValue (getSolver s) x++value :: SatSolver s => s -> Lit -> IO (Maybe Bool)+value s x = M.value (getSolver s) x++--------------------------------------------------------------------------------
+ src/Jukebox/Sat3.hs view
@@ -0,0 +1,47 @@+module Jukebox.Sat3 where++import Jukebox.Sat++--------------------------------------------------------------------------------++data Lit3 = Lit3{ isFalse :: Lit, isTrue :: Lit }++false3, true3, bottom3 :: Lit3+false3  = Lit3 true false+true3   = neg3 false3+bottom3 = Lit3 false false++neg3 :: Lit3 -> Lit3+neg3 (Lit3 f t) = Lit3 t f++newLit3 :: SatSolver s => s -> IO Lit3+newLit3 s =+  do a <- newLit s+     b <- newLit s+     addClause s [neg a, neg b]+     return (Lit3 a b)++newLit2 :: SatSolver s => s -> IO Lit3+newLit2 s =+  do a <- newLit s+     return (Lit3 a (neg a))++--------------------------------------------------------------------------------++modelValue3 :: SatSolver s => s -> Lit3 -> IO (Maybe Bool)+modelValue3 s = val3 (modelValue s)++value3 :: SatSolver s => s -> Lit3 -> IO (Maybe Bool)+value3 s = val3 (value s)++val3 :: (Lit -> IO (Maybe Bool)) -> Lit3 -> IO (Maybe Bool)+val3 get (Lit3 f t) =+  do mf <- get f+     case mf of+       Just True -> do return (Just False)+       _         -> do mt <- get t+                       case mt of+                         Just True -> return (Just True)+                         _         -> return Nothing++--------------------------------------------------------------------------------
+ src/Jukebox/SatEq.hs view
@@ -0,0 +1,84 @@+module Jukebox.SatEq where++import Jukebox.Sat+import Jukebox.Sat3++import Data.IORef+import Data.Map as M++--------------------------------------------------------------------------------++data SolverEq =+  SolverEq+  { satSolver :: Solver+  , counter   :: IORef Int+  , table     :: IORef (Map (Elt,Elt) Lit3)+  , model     :: IORef (Maybe (Map Elt Elt))+  }++newSolverEq :: Solver -> IO SolverEq+newSolverEq s =+  do ctr <- newIORef 0+     tab <- newIORef M.empty+     mod <- newIORef Nothing+     return SolverEq+       { satSolver = s+       , counter   = ctr+       , table     = tab+       , model     = mod+       }++instance SatSolver SolverEq where+  getSolver = satSolver++class SatSolver s => EqSolver s where+  getSolverEq :: s -> SolverEq++instance EqSolver SolverEq where+  getSolverEq s = s++--------------------------------------------------------------------------------++newtype Elt = Elt Int+  deriving ( Eq, Ord )++instance Show Elt where+  show (Elt k) = "#" ++ show k++newElt :: EqSolver s => s -> IO Elt+newElt s =+  do k <- readIORef (counter (getSolverEq s))+     writeIORef (counter (getSolverEq s)) $! k+1+     return (Elt k)++equal :: EqSolver s => s -> Elt -> Elt -> IO Lit3+equal s x y =+  case x `compare` y of+    GT -> equal s y x+    EQ -> return true3+    LT -> do tab <- readIORef (table (getSolverEq s))+             case M.lookup (x,y) tab of+               Just q ->+                 do return q+       +               Nothing ->+                 do q <- newLit3 s+                    writeIORef (table (getSolverEq s)) (M.insert (x,y) q tab)+                    return q++--------------------------------------------------------------------------------++solveEq :: EqSolver s => s -> [Lit] -> IO Bool+solveEq = undefined++--------------------------------------------------------------------------------++modelRep :: EqSolver s => s -> Elt -> IO (Maybe Elt)+modelRep s x =+  do mmod <- readIORef (model (getSolverEq s))+     return $+       case mmod of+         Just mp -> M.lookup x mp+         Nothing -> Nothing++--------------------------------------------------------------------------------
+ src/Jukebox/SatMin.hs view
@@ -0,0 +1,29 @@+module Jukebox.SatMin where++import Jukebox.Sat++solveLocalMin :: SatSolver s => s -> [Lit] -> [Lit] -> IO Bool+solveLocalMin s as ms =+  do b <- solve s as+     if b then do l <- newLit s -- used as a local assumption for this minimization+                  localMin s as l ms+                  addClause s [neg l]+                  return True+          else do return False++localMin :: SatSolver s => s -> [Lit] -> Lit -> [Lit] -> IO ()+localMin s as l ms =+  do -- find out the current values of the m's+     bs <- sequence [ modelValue s m | m <- ms ]+  +     -- assert that all false m's should stay false+     sequence_ [ addClause s [neg l, neg m] | (m,b) <- ms `zip` bs, b /= Just True ]+     +     -- assert that at least one true m should become false also+     let ms1 = [ m | (m,Just True)  <- ms `zip` bs ]+     addClause s (neg l : [ neg m | m <- ms1 ])+     +     -- is there still a solution?+     b <- solve s (l:as)+     if b then localMin s as l ms1+          else return ()
+ src/Jukebox/TPTP/FindFile.hs view
@@ -0,0 +1,38 @@+module Jukebox.TPTP.FindFile where++import System.FilePath+import System.Directory(doesFileExist)+import System.Environment+import Control.Exception+import Control.Monad+import Jukebox.Options++findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)+findFile [] _file = return Nothing+findFile (path:paths) file = do+  let candidate = path </> file+  exists <- doesFileExist candidate+  if exists then return (Just candidate)+   else findFile paths file++findFileTPTP :: [FilePath] -> FilePath -> IO (Maybe FilePath)+findFileTPTP dirs file = do+  let candidates = [file, "Problems" </> file,+                    "Problems" </> take 3 file </> file]+  fmap msum (mapM (findFile dirs) candidates)++getTPTPDirs :: IO [FilePath]+getTPTPDirs = do { dir <- getEnv "TPTP"; return [dir] } `catch` f+  where f :: IOException -> IO [FilePath]+        f _ = return []++findFileFlags =+  concat <$>+  sequenceA [+    pure ["."],+    flag "root"+      ["Extra directories that will be searched for TPTP input files."]+      []+      argFiles,+    io getTPTPDirs+    ]
+ src/Jukebox/TPTP/Lexer.x view
@@ -0,0 +1,204 @@+-- -*- mode: haskell -*-++-- Roughly taken from the TPTP syntax reference+{+{-# OPTIONS_GHC -O2 -fno-warn-deprecated-flags #-}+{-# LANGUAGE BangPatterns #-}+module Jukebox.TPTP.Lexer(+  scan,+  Pos(..),+  Token(..),+  Punct(..),+  Defined(..),+  Keyword(..),+  TokenStream(..),+  Contents(..)) where++import Data.Word+import Data.Char+}++$alpha = [a-zA-Z0-9_]+$anything = [. \n]+@quoted = ($printable # [\\']) | \\ $printable+@dquoted = ($printable # [\\\"]) | \\ $printable++tokens :-+-- Comments and whitespace+"%" .* ;+"/*" (($anything # \*)* "*"++      ($anything # [\/\*]))*+     ($anything # \*)* "*"* "*/" ; -- blech!+$white+ ;++-- Keywords.+"thf" { k Thf }+"tff" { k Tff }+"fof" { k Fof }+"cnf" { k Cnf }+"axiom" { k Axiom }+"hypothesis" { k Hypothesis }+"definition" { k Definition }+"assumption" { k Assumption }+"lemma" { k Lemma }+"theorem" { k Theorem }+"conjecture" { k Conjecture }+"negated_conjecture" { k NegatedConjecture }+"question" { k Question }+"plain" { k Plain }+"fi_domain" { k FiDomain }+"fi_hypothesis" { k FiHypothesis }+"fi_predicates" { k FiPredicates }+"type" { k Type }+"unknown" { k Unknown }+"include" { k Include }+-- Defined symbols.+"$true" { d DTrue }+"$false" { d DFalse }+"$equal" { d DEqual }+"$distinct" { d DDistinct }+"$itef" { d DItef }+"$itett" | "$itetf" { d DItet }+"$o" | "$oType" { d DO }+"$i" | "$iType" { d DI }+"$tType" { d DTType }+-- Atoms.+"$"{0,2} [a-z] $alpha* { Atom Normal . copy }+-- Atoms with funny quoted names (here we diverge from the official+-- syntax, which only allows the escape sequences \\ and \' in quoted+-- atoms: we allow \ to be followed by any printable character)+"'"  @quoted+ "'" { Atom Normal . unquote }+-- Vars are easy :)+[A-Z][$alpha]* { Var . copy }+-- Distinct objects, which are double-quoted+\" @dquoted+  \" { DistinctObject . unquote }+-- Integers+[\+\-]? (0 | [1-9][0-9]*)/($anything # $alpha) { Number . read }++-- Operators (FOF)+"("  { p LParen }  ")"   { p RParen }  "["  { p LBrack }   "]"  { p RBrack }+","  { p Comma }   "."   { p Dot }     "|"  { p Or }       "&"  { p And }+"~"  { p Not }     "<=>" { p Iff }     "=>" { p Implies }  "<=" { p Follows }+"<~>"{ p Xor }     "~|"  { p Nor }     "~&" { p Nand }     "="  { p Eq }+"!=" { p Neq }     "!"   { p ForAll }  "?"  { p Exists }   ":=" { p Let }+":-" { p LetTerm }+-- Operators (TFF)+":" { p Colon }    "*"   { p Times }   "+"  { p Plus }     ">"  { p FunArrow }+-- Operators (THF)+"^"  { p Lambda } "@" { p Apply }  "!!" { p ForAllLam }  "??"  { p ExistsLam }+"@+" { p Some }   "@-" { p The }   "<<" { p Subtype }    "-->" { p SequentArrow }+"!>" { p DependentProduct }        "?*" { p DependentSum }++{+data Pos = Pos {-# UNPACK #-} !Word {-# UNPACK #-} !Word deriving Show+data Token = Atom { keyword :: !Keyword, tokenName :: !String }+           | Defined { defined :: !Defined  }+           | Var { tokenName :: !String }+           | DistinctObject { tokenName :: !String }+           | Number { value :: !Integer }+           | Punct { kind :: !Punct }+           | Eof+           | Error++data Keyword = Normal+             | Thf | Tff | Fof | Cnf+             | Axiom | Hypothesis | Definition | Assumption+             | Lemma | Theorem | Conjecture | NegatedConjecture | Question+             | Plain | FiDomain | FiHypothesis | FiPredicates | Type | Unknown+             | Include deriving (Eq, Ord)++instance Show Keyword where+  show x =+    case x of {+      Normal -> "normal";+      Thf -> "thf"; Tff -> "tff"; Fof -> "fof"; Cnf -> "cnf";+      Axiom -> "axiom"; Hypothesis -> "hypothesis"; Definition -> "definition";+      Assumption -> "assumption"; Lemma -> "lemma"; Theorem -> "theorem";+      Conjecture -> "conjecture"; NegatedConjecture -> "negated_conjecture";+      Question -> "question"; Plain -> "plain"; FiDomain -> "fi_domain";+      FiHypothesis -> "fi_hypothesis"; FiPredicates -> "fi_predicates";+      Type -> "type"; Unknown -> "unknown"; Include -> "include" }++-- We only include defined names that need special treatment from the+-- parser here: you can freely make up any other names starting with a+-- '$' and they get turned into Atoms.+data Defined = DTrue | DFalse | DEqual | DDistinct | DItef | DItet+             | DO | DI | DTType deriving (Eq, Ord)++instance Show Defined where+  show x =+    case x of {+      DTrue -> "$true"; DFalse -> "$false"; DEqual -> "$equal";+      DDistinct -> "$distinct"; DItef -> "$itef"; DItet -> "$itet";+      DO -> "$o"; DI -> "$i"; DTType -> "$tType" }++data Punct = LParen | RParen | LBrack | RBrack | Comma | Dot+           | Or | And | Not | Iff | Implies | Follows | Xor | Nor | Nand+           | Eq | Neq | ForAll | Exists | Let | LetTerm -- FOF+           | Colon | Times | Plus | FunArrow -- TFF+           | Lambda | Apply | ForAllLam | ExistsLam+           | DependentProduct | DependentSum | Some | The+           | Subtype | SequentArrow -- THF+             deriving (Eq, Ord)++instance Show Punct where+  show x =+    case x of {+      LParen -> "("; RParen -> ")"; LBrack -> "["; RBrack -> "]";+      Comma -> ","; Dot -> "."; Or -> "|"; And -> "&"; Not -> "~";+      Iff -> "<=>"; Implies -> "=>"; Follows -> "<="; Xor -> "<~>";+      Nor -> "~|"; Nand -> "~&"; Eq -> "="; Neq -> "!="; ForAll -> "!";+      Exists -> "?"; Let -> ":="; Colon -> ":"; Times -> "*"; Plus -> "+";+      FunArrow -> ">"; Lambda -> "^"; Apply -> "@"; ForAllLam -> "!!";+      ExistsLam -> "??"; Some -> "@+"; The -> "@-"; Subtype -> "<<";+      SequentArrow -> "-->"; DependentProduct -> "!>"; DependentSum -> "?*";+      LetTerm -> ":-" }++p x = const (Punct x)+k x = Atom x . copy+d x = const (Defined x)++copy :: String -> String+copy = id++unquote :: String -> String+unquote (_:x)+  | null z = init y+  | otherwise = y ++ [z !! 1] ++ unquote (drop 2 z)+  where (y, z) = break (== '\\') x+    +-- The main scanner function, heavily modified from Alex's posn-bytestring wrapper.++data TokenStream = At {-# UNPACK #-} !Pos !Contents+data Contents = Cons !Token TokenStream++scan xs = go (Input (Pos 1 1) '\n' xs)+  where go inp@(Input pos _ xs) =+          case alexScan inp 0 of+                AlexEOF -> let t = At pos (Cons Eof t) in t+                AlexError _ -> let t = At pos (Cons Error t) in t+                AlexSkip  inp' _ -> go inp'+                AlexToken inp' len act ->+                  At pos (act (take len xs) `Cons` go inp')++data AlexInput = Input {-# UNPACK #-} !Pos {-# UNPACK #-} !Char String++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (Input _ c _) = c++{-# INLINE alexGetByte #-}+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte i = fmap f (alexGetChar i)+  where f (c, i') = (fromIntegral (ord c), i')+{-# INLINE alexGetChar #-}+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar (Input p _ (x:xs)) =+  Just (x, Input (advance p x) x xs)+alexGetChar _ = Nothing++{-# INLINE advance #-}+advance :: Pos -> Char -> Pos+advance (Pos l c) '\t' = Pos  l    (c+8 - (c-1) `mod` 8)+advance (Pos l _) '\n' = Pos (l+1) 1+advance (Pos l c) _    = Pos  l    (c+1)+}
+ src/Jukebox/TPTP/Parse.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Jukebox.TPTP.Parse where++import Jukebox.TPTP.FindFile+import qualified Jukebox.TPTP.Parse.Core as Parser+import Control.Monad.IO.Class+import Control.Monad.Trans.Except+import Jukebox.Form hiding (Pos, run)+import Control.Exception+import Data.List+import System.IO++parseString :: String -> IO (Problem Form)+parseString xs =+  case Parser.parseProblem "<string>" xs of+    Parser.ParseFailed loc msg ->+      error ("Parse error at " ++ show loc ++ ":\n" ++ unlines msg)+    Parser.ParseSucceeded prob ->+      return prob+    Parser.ParseStalled loc _ _ ->+      error ("Include directive found at " ++ show loc)++parseProblem :: [FilePath] -> FilePath -> IO (Either String (Problem Form))+parseProblem dirs name = parseProblemWith (findFileTPTP dirs) name++parseProblemWith :: (FilePath -> IO (Maybe FilePath)) -> FilePath -> IO (Either String (Problem Form))+parseProblemWith findFile name =+  runExceptT $ do+    file <- readInFile (Parser.Location "<command line>" 0 0) name+    process (Parser.parseProblem name file)++  where+    err loc msg = throwE msg'+      where+        msg' = "Error in " ++ show loc ++ ":\n" ++ msg++    readInFile pos name = do+      mfile <- liftIO (findFile name)+      case mfile of+        Nothing ->+          err pos ("File '" ++ name ++ "' not found")+        Just file ->+          ExceptT $ do+            liftIO $ hPutStrLn stderr $ "Reading " ++ file ++ "..."+            fmap Right (readFile file) `catch`+              \(e :: IOException) -> return (Left (show e))++    process (Parser.ParseFailed loc msg) = err loc (intercalate "\n" msg)+    process (Parser.ParseSucceeded prob) = return prob+    process (Parser.ParseStalled loc name cont) = do+      file <- readInFile loc name+      process (cont file)
+ src/Jukebox/TPTP/Parse/Core.hs view
@@ -0,0 +1,528 @@+-- Parse and typecheck TPTP clauses, stopping at include-clauses.++{-# LANGUAGE BangPatterns, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeOperators, TypeFamilies, CPP, DeriveFunctor #-}+{-# OPTIONS_GHC -funfolding-use-threshold=1000 #-}+module Jukebox.TPTP.Parse.Core where++#include "errors.h"+import Jukebox.TPTP.Parsec+import Control.Applicative+import Control.Monad+import qualified Data.Map.Strict as Map+import Data.Map(Map)+import Data.List+import Jukebox.TPTP.Print+import Jukebox.Name+import qualified Data.Set as Set+import Data.Int++import Jukebox.TPTP.Lexer hiding+  (Pos, Error, Include, Var, Type, Not, ForAll,+   Exists, And, Or, Type, Apply, Implies, Follows, Xor, Nand, Nor,+   keyword, defined, kind)+import qualified Jukebox.TPTP.Lexer as L+import qualified Jukebox.Form as Form+import Jukebox.Form hiding (tag, kind, Axiom, Conjecture, Question, newFunction, TypeOf(..), run)+import qualified Jukebox.Name as Name++-- The parser monad++data ParseState =+  MkState ![Input Form]          -- problem being constructed, inputs are in reverse order+          !(Map String Type)     -- types in scope+          !(Map String Function) -- functions in scope+          !(Map String Variable) -- variables in scope, for CNF+          !Int64                 -- unique supply+type Parser = Parsec ParsecState+type ParsecState = UserState ParseState TokenStream++-- An include-clause.+data IncludeStatement = Include String (Maybe [Tag]) deriving Show++-- The initial parser state.+initialState :: ParseState+initialState = initialStateFrom [] Map.empty Map.empty++initialStateFrom :: [Name] -> Map String Type -> Map String (Name ::: FunType) -> ParseState+initialStateFrom xs tys fs = MkState [] tys fs Map.empty n+  where+    n = maximum (0:[succ m | Unique m _ _ <- xs])++instance Stream TokenStream Token where+  primToken (At _ (Cons Eof _)) _ok err _fatal = err+  primToken (At _ (Cons L.Error _)) _ok _err fatal = fatal "Lexical error"+  primToken (At _ (Cons t ts)) ok _err _fatal = ok ts t+  type Position TokenStream = TokenStream+  position = id++-- The main parsing function.+data ParseResult a =+    ParseFailed Location [String]+  | ParseSucceeded a+  | ParseStalled Location FilePath (String -> ParseResult a)+  deriving Functor++instance Applicative ParseResult where+  pure = return+  (<*>) = liftM2 ($)++instance Monad ParseResult where+  return = ParseSucceeded+  ParseFailed loc err >>= _ = ParseFailed loc err+  ParseSucceeded x >>= f = f x+  ParseStalled loc name k >>= f =+    ParseStalled loc name (\xs -> k xs >>= f)++data Location = Location FilePath Integer Integer+instance Show Location where+  show (Location file row col) =+    file ++ " (line " ++ show row ++ ", column " ++ show col ++ ")"++makeLocation :: FilePath -> L.Pos -> Location+makeLocation file (L.Pos row col) =+  Location file (fromIntegral row) (fromIntegral col)++parseProblem :: FilePath -> String -> ParseResult [Input Form]+parseProblem name contents = parseProblemFrom initialState name contents++parseProblemFrom :: ParseState -> FilePath -> String -> ParseResult [Input Form]+parseProblemFrom state name contents =+  fmap finalise $+    aux Nothing name (UserState state (scan contents))+  where+    aux :: Maybe [Tag] -> FilePath -> ParsecState -> ParseResult ParseState+    aux tags name state =+      case run report (section (included tags)) state of+        (UserState{userStream = At pos _}, Left err) ->+          ParseFailed (makeLocation name pos) err+        (UserState{userState = state'}, Right Nothing) ->+          return state'+        (UserState state (input'@(At pos _)),+         Right (Just (Include name' tags'))) ->+          ParseStalled (makeLocation name pos) name' $ \input -> do+            state' <- aux (tags `merge` tags') name' (UserState state (scan input))+            aux tags name (UserState state' input')++    report :: ParsecState -> [String]+    report UserState{userStream = At _ (Cons Eof _)} =+      ["Unexpected end of file"]+    report UserState{userStream = At _ (Cons L.Error _)} =+      ["Lexical error"]+    report UserState{userStream = At _ (Cons t _)} =+      ["Unexpected " ++ show t]++    included :: Maybe [Tag] -> Tag -> Bool+    included Nothing _ = True+    included (Just xs) x = x `elem` xs++    merge :: Maybe [Tag] -> Maybe [Tag] -> Maybe [Tag]+    merge Nothing x = x+    merge x Nothing = x+    merge (Just xs) (Just ys) = Just (xs `intersect` ys)++    finalise :: ParseState -> Problem Form+    finalise (MkState p _ _ _ _) = check (reverse p)++-- Wee function for testing.+testParser :: Parser a -> String -> Either [String] a+testParser p s = snd (run (const []) p (UserState initialState (scan s)))++-- Primitive parsers.++{-# INLINE keyword' #-}+keyword' p = satisfy p'+  where p' Atom { L.keyword = k } = p k+        p' _ = False+{-# INLINE keyword #-}+keyword k = keyword' (== k) <?> "'" ++ show k ++ "'"+{-# INLINE punct' #-}+punct' p = satisfy p'+  where p' Punct { L.kind = k } = p k+        p' _ = False+{-# INLINE punct #-}+punct k = punct' (== k) <?> "'" ++ show k ++ "'"+{-# INLINE defined' #-}+defined' p = fmap L.defined (satisfy p')+  where p' Defined { L.defined = d } = p d+        p' _ = False+{-# INLINE defined #-}+defined k = defined' (== k) <?> "'" ++ show k ++ "'"+{-# INLINE variable #-}+variable = fmap tokenName (satisfy p) <?> "variable"+  where p L.Var{} = True+        p _ = False+{-# INLINE number #-}+number = fmap value (satisfy p) <?> "number"+  where p Number{} = True+        p _ = False+{-# INLINE atom #-}+atom = fmap tokenName (keyword' (const True)) <?> "atom"++-- Combinators.++parens, bracks :: Parser a -> Parser a+{-# INLINE parens #-}+parens p = between (punct LParen) (punct RParen) p+{-# INLINE bracks #-}+bracks p = between (punct LBrack) (punct RBrack) p++-- Build an expression parser from a binary-connective parser+-- and a leaf parser.+binExpr :: Parser a -> Parser (a -> a -> Parser a) -> Parser a+binExpr leaf op = do+  lhs <- leaf+  do { f <- op; rhs <- binExpr leaf op; f lhs rhs } <|> return lhs++-- Parsing clauses.++-- Parse as many things as possible until EOF or an include statement.+section :: (Tag -> Bool) -> Parser (Maybe IncludeStatement)+section included = skipMany (input included) >> (fmap Just include <|> (eof >> return Nothing))++-- A single non-include clause.+input :: (Tag -> Bool) -> Parser ()+input included = declaration Cnf (formulaIn cnf) <|>+                 declaration Fof (formulaIn fof) <|>+                 declaration Tff (\tag -> formulaIn tff tag <|> typeDeclaration)+  where {-# INLINE declaration #-}+        declaration k m = do+          keyword k+          parens $ do+            t <- tag+            punct Comma+            -- Don't bother typechecking clauses that we are not+            -- supposed to include in the problem (seems in the+            -- spirit of TPTP's include mechanism)+            if included t then m t else balancedParens+          punct Dot+          return ()+        formulaIn lang tag = do+          k <- kind+          punct Comma+          form <- lang+          newFormula (k tag form)+        balancedParens = skipMany (parens balancedParens <|> (satisfy p >> return ()))+        p Punct{L.kind=LParen} = False+        p Punct{L.kind=RParen} = False+        p _ = True++-- A TPTP kind.+kind :: Parser (Tag -> Form -> Input Form)+kind = axiom Axiom <|> axiom Hypothesis <|> axiom Definition <|>+       axiom Assumption <|> axiom Lemma <|> axiom Theorem <|>+       general Conjecture Form.Conjecture <|>+       general NegatedConjecture Form.Axiom <|>+       general Question Form.Question+  where axiom t = general t Form.Axiom+        general k kind = keyword k >> return (mk kind)+        mk kind tag form =+          Input { Form.tag = tag,+                  Form.kind = kind,+                  Form.what = form }++-- A formula name.+tag :: Parser Tag+tag = atom <|> fmap show number <?> "clause name"++-- An include declaration.+include :: Parser IncludeStatement+include = do+  keyword L.Include+  res <- parens $ do+    name <- atom <?> "quoted filename"+    clauses <- do { punct Comma+                  ; fmap Just (bracks (sepBy1 tag (punct Comma))) } <|> return Nothing+    return (Include name clauses)+  punct Dot+  return res++-- Inserting types, functions and clauses.++newFormula :: Input Form -> Parser ()+newFormula input = do+  MkState p t f v n <- getState+  putState (MkState (input:p) t f v n)+  +newFunction :: String -> FunType -> Parser (Name ::: FunType)+newFunction name ty' = do+  f@(_ ::: ty) <- lookupFunction ty' name+  unless (ty == ty') $ do+    fatalError $ "Constant " ++ name +++                 " was declared to have type " ++ prettyShow ty' +++                 " but already has type " ++ prettyShow ty+  return f++{-# INLINE applyFunction #-}+applyFunction :: String -> [Term] -> Type -> Parser Term+applyFunction name args' res = do+  f@(_ ::: ty) <- lookupFunction (FunType (replicate (length args') individual) res) name+  unless (map typ args' == args ty) $ typeError f args'+  return (f :@: args')++{-# NOINLINE typeError #-}+typeError f@(x ::: ty) args' = do+    let plural 1 x _ = x +        plural _ _ y = y+    fatalError $ "Type mismatch in term '" ++ prettyShow (f :@: args') ++ "': " +++                 "Constant " ++ prettyShow x +++                 if length (args ty) == length args' then+                   " has type " ++ prettyShow ty +++                   " but was applied to " ++ plural (length args') "an argument" "arguments" +++                   " of type " ++ prettyShow (map typ args')+                 else+                   " has arity " ++ show (length args') +++                   " but was applied to " ++ show (length (args ty)) +++                   plural (length (args ty)) " argument" " arguments"++{-# INLINE lookupType #-}+lookupType :: String -> Parser Type+lookupType xs = do+  MkState p t f v n <- getState+  case Map.lookup xs t of+    Nothing -> do+      let ty = Type (name xs) Infinite Infinite+      putState (MkState p (Map.insert xs ty t) f v n)+      return ty+    Just ty -> return ty++{-# INLINE lookupFunction #-}+lookupFunction :: FunType -> String -> Parser (Name ::: FunType)+lookupFunction def x = do+  MkState p t f v n <- getState+  case Map.lookup x f of+    Nothing -> do+      let decl = name x ::: def+      putState (MkState p t (Map.insert x decl f) v n)+      return decl+    Just f -> return f++-- The type $i (anything whose type is not specified gets this type)+individual :: Type+individual = Type (name "$i") Infinite Infinite++-- Parsing formulae.++cnf, tff, fof :: Parser Form+cnf = do+  MkState p t f _ n <- getState+  putState (MkState p t f Map.empty n)+  formula NoQuantification __+tff = formula Typed Map.empty+fof = formula Untyped Map.empty++-- We cannot always know whether what we are parsing is a formula or a+-- term, since we don't have lookahead. For example, p(x) might be a+-- formula, but in p(x)=y, p(x) is a term.+--+-- To deal with this, we introduce the Thing datatype.+-- A thing is either a term or a formula, or a literal that we don't know+-- if it should be a term or a formula. Instead of a separate formula-parser+-- and term-parser we have a combined thing-parser.+data Thing = Apply !String ![Term]+           | Term !Term+           | Formula !Form++instance Show Thing where+  show (Apply f []) = f+  show (Apply f args) =+    f +++      case args of+        [] -> ""+        args -> prettyShow args+  show (Term t) = prettyShow t+  show (Formula f) = prettyShow f++-- However, often we do know whether we want a formula or a term,+-- and there it's best to use a specialised parser (not least because+-- the error messages are better). For that reason, our parser is+-- parametrised on the type of thing you want to parse. We have two+-- main parsers:+--   * 'term' parses an atomic expression+--   * 'formula' parses an arbitrary expression+-- You can instantiate 'term' for Term, Form or Thing; in each case+-- you get an appropriate parser. You can instantiate 'formula' for+-- Form or Thing.++-- Types for which a term f(...) is a valid literal. These are the types on+-- which you can use 'term'.+class TermLike a where+  -- Convert from a Thing.+  fromThing :: Thing -> Parser a+  -- Parse a variable occurrence as a term on its own, if that's allowed.+  var :: Mode -> Map String Variable -> Parser a+  -- A parser for this type.+  parser :: Mode -> Map String Variable -> Parser a++data Mode = Typed | Untyped | NoQuantification++instance TermLike Form where+  {-# INLINE fromThing #-}+  fromThing (Apply x xs) = fmap (Literal . Pos . Tru) (applyFunction x xs O)+  fromThing (Term _) = mzero+  fromThing (Formula f) = return f+  -- A variable itself is not a valid formula.+  var _ _ = mzero+  parser = formula++instance TermLike Term where+  {-# INLINE fromThing #-}+  fromThing (Apply x xs) = applyFunction x xs individual+  fromThing (Term t) = return t+  fromThing (Formula _) = mzero+  parser = term++  {-# INLINE var #-}+  var NoQuantification _ = do+    x <- variable+    MkState p t f ctx n <- getState+    case Map.lookup x ctx of+      Just v -> return (Var v)+      Nothing -> do+        let v = Unique (n+1) x defaultRenamer ::: individual+        putState (MkState p t f (Map.insert x v ctx) (n+1))+        return (Var v)+  var _ ctx = do+    x <- variable+    case Map.lookup x ctx of+      Just v -> return (Var v)+      Nothing -> fatalError $ "unbound variable " ++ x++instance TermLike Thing where+  fromThing = return+  var mode ctx = fmap Term (var mode ctx)+  parser = formula++-- Types that can represent formulae. These are the types on which+-- you can use 'formula'.+class TermLike a => FormulaLike a where+  fromFormula :: Form -> a++instance FormulaLike Form where fromFormula = id+instance FormulaLike Thing where fromFormula = Formula++-- An atomic expression.+{-# INLINEABLE term #-}+term :: TermLike a => Mode -> Map String Variable -> Parser a+term mode ctx = function <|> var mode ctx <|> parens (parser mode ctx)+  where {-# INLINE function #-}+        function = do+          x <- atom+          args <- parens (sepBy1 (term mode ctx) (punct Comma)) <|> return []+          fromThing (Apply x args)++literal, unitary, quantified, formula ::+  FormulaLike a => Mode -> Map String Variable -> Parser a+{-# INLINE literal #-}+literal mode ctx = true <|> false <|> binary <?> "literal"+  where {-# INLINE true #-}+        true = do { defined DTrue; return (fromFormula (And [])) }+        {-# INLINE false #-}+        false = do { defined DFalse; return (fromFormula (Or [])) }+        binary = do+          x <- term mode ctx :: Parser Thing+          let {-# INLINE f #-}+              f p sign = do+               punct p+               lhs <- fromThing x :: Parser Term+               rhs <- term mode ctx :: Parser Term+               let form = Literal . sign $ lhs :=: rhs+               when (typ lhs /= typ rhs) $+                 fatalError $ "Type mismatch in equality '" ++ prettyShow form ++ +                              "': left hand side has type " ++ prettyShow (typ lhs) +++                              " but right hand side has type " ++ prettyShow (typ rhs)+               return (fromFormula form)+          f Eq Pos <|> f Neq Neg <|> fromThing x++{-# INLINEABLE unitary #-}+unitary mode ctx = negation <|> quantified mode ctx <|> literal mode ctx+  where {-# INLINE negation #-}+        negation = do+          punct L.Not+          fmap (fromFormula . Not) (unitary mode ctx :: Parser Form)++{-# INLINE quantified #-}+quantified mode ctx = do+  q <- (punct L.ForAll >> return ForAll) <|>+       (punct L.Exists >> return Exists)+  vars <- bracks (sepBy1 (binder mode) (punct Comma))+  let ctx' = foldl' (\m v -> Map.insert (Name.base (Name.name v)) v m) ctx vars+  punct Colon+  rest <- unitary mode ctx' :: Parser Form+  return (fromFormula (q (Bind (Set.fromList vars) rest)))++-- A general formula.+{-# INLINEABLE formula #-}+formula mode ctx = do+  x <- unitary mode ctx :: Parser Thing+  let binop op t u = op [t, u]+      {-# INLINE connective #-}+      connective p op = do+        punct p+        lhs <- fromThing x+        rhs <- formula mode ctx :: Parser Form+        return (fromFormula (op lhs rhs))+  connective L.And (binop And) <|> connective L.Or (binop Or) <|>+   connective Iff Equiv <|>+   connective L.Implies (Connective Implies) <|>+   connective L.Follows (Connective Follows) <|>+   connective L.Xor (Connective Xor) <|>+   connective L.Nor (Connective Nor) <|>+   connective L.Nand (Connective Nand) <|>+   fromThing x++binder :: Mode -> Parser Variable+binder NoQuantification =+  fatalError "Used a quantifier in a CNF clause"+binder mode = do+  x <- variable+  ty <- do { punct Colon;+             case mode of {+               Typed -> return ();+               Untyped ->+                 fatalError "Used a typed quantification in an untyped formula" };+             type_ } <|> return individual+  MkState p t f v n <- getState+  putState (MkState p t f v (n+1))+  return (Unique n x defaultRenamer ::: ty)++-- Parse a type+type_ :: Parser Type+type_ =+  do { x <- atom; lookupType x } <|>+  do { defined DI; return individual }++-- A little data type to help with parsing types.+data Type_ = TType | Fun [Type] Type | Prod [Type]++prod :: Type_ -> Type_ -> Parser Type_+prod (Prod tys) (Prod tys2) | not (O `elem` tys ++ tys2) = return $ Prod (tys ++ tys2)+prod _ _ = fatalError "invalid type"++arrow :: Type_ -> Type_ -> Parser Type_+arrow (Prod ts) (Prod [x]) = return $ Fun ts x+arrow _ _ = fatalError "invalid type"++leaf :: Parser Type_+leaf = do { defined DTType; return TType } <|>+       do { defined DO; return (Prod [O]) } <|>+       do { ty <- type_; return (Prod [ty]) } <|>+       parens compoundType++compoundType :: Parser Type_+compoundType = leaf `binExpr` (punct Times >> return prod)+                    `binExpr` (punct FunArrow >> return arrow)++typeDeclaration :: Parser ()+typeDeclaration = do+  keyword L.Type+  punct Comma+  let manyParens p = parens (manyParens p) <|> p+  manyParens $ do+    name <- atom+    punct Colon+    res <- compoundType+    case res of+      TType -> return ()+      Fun args res -> do { newFunction name (FunType args res); return () }+      Prod [res] -> do { newFunction name (FunType [] res); return () }+      _ -> fatalError "invalid type"
+ src/Jukebox/TPTP/ParseSnippet.hs view
@@ -0,0 +1,49 @@+-- Parse little bits of TPTP, e.g. a prelude for a particular tool.++module Jukebox.TPTP.ParseSnippet where++import Jukebox.TPTP.Parse.Core as TPTP.Parse.Core+import Jukebox.TPTP.Parsec as TPTP.Parsec+import Jukebox.TPTP.Lexer+import Jukebox.Name+import Jukebox.Form+import qualified Data.Map.Strict as Map+import Data.List++tff, cnf :: [(String, Type)] -> [(String, Function)] -> String -> Form+tff = form TPTP.Parse.Core.tff+cnf = form TPTP.Parse.Core.cnf++form :: Symbolic a => Parser a -> [(String, Type)] -> [(String, Function)] -> String -> a+form parser types funs0 str =+  case run_ (parser <* eof)+            (UserState (MkState [] (Map.delete "$i" (Map.fromList types)) (Map.fromList funs) Map.empty 0) (scan str)) of+    Ok (UserState (MkState _ types' funs' _ _) (At _ (Cons Eof _))) res+      | Map.insert "$i" individual (Map.fromList types) /=+        Map.insert "$i" individual types' ->+        error $ "ParseSnippet: type implicitly defined: " +++                show (map snd (Map.toList types' \\ types))+      | Map.fromList funs /= funs' ->+        error $ "ParseSnippet: function implicitly defined: " +++                show (map snd (Map.toList funs' \\ funs))+      | otherwise -> mapType elimI res+    Ok{} -> error "ParseSnippet: lexical error"+    TPTP.Parsec.Error _ msg -> error $ "ParseSnippet: arse error: " ++ msg+    Expected _ exp -> error $ "ParseSnippet: parse error: expected " ++ show exp++  where+    funs = map (mapFunType introI) funs0++    mapFunType f (xs, name ::: FunType args res) =+      (xs, name ::: FunType (map f args) (f res))++    elimI =+      case lookup "$i" types of+        Nothing -> id+        Just i ->+          \ty -> if ty == individual then i else ty+    introI =+      case lookup "$i" types of+        Nothing -> id+        Just i ->+          \ty -> if ty == i then individual else ty
+ src/Jukebox/TPTP/Parsec.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE RankNTypes, BangPatterns, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeFamilies #-}+{-# OPTIONS_GHC -funfolding-creation-threshold=10000 -funfolding-use-threshold=10000 #-}+module Jukebox.TPTP.Parsec where++import Control.Applicative+import Control.Monad+import Data.List++-- Parser type and monad instances++newtype Parsec a b = Parsec+  { runParsec :: forall c.+                 (b -> Reply a c -> a -> Reply a c) -- ok: success+              -> Reply a c -- err: backtracking failure+              -> a -> Reply a c }++type Reply a b = [String] -> Result (Position a) b++data Result a b = Ok a b | Error a String | Expected a [String]++{-# INLINE parseError #-}+parseError :: [String] -> Parsec a b+parseError e = Parsec (\_ok err _inp exp -> err (e ++ exp))++{-# INLINE fatalError #-}+fatalError :: Stream a c => String -> Parsec a b+fatalError e = Parsec (\_ok _err inp _ -> Error (position inp) e)++instance Functor (Parsec a) where+  {-# INLINE fmap #-}+  fmap f x = x >>= return . f++instance Monad (Parsec a) where+  {-# INLINE return #-}+  return x = Parsec (\ok err inp exp -> ok x err inp exp)+  {-# INLINE (>>=) #-}+  x >>= f = Parsec (\ok err inp exp  -> runParsec x (\y err inp exp -> runParsec (f y) ok err inp exp) err inp exp)+  {-# INLINE fail #-}+  fail _ = parseError []++instance MonadPlus (Parsec a) where+  {-# INLINE mzero #-}+  mzero = Parsec (\_ok err _inp exp -> err exp)+  {-# INLINE mplus #-}+  m1 `mplus` m2 = Parsec (\ok err inp exp ->+    runParsec m1 ok (\exp -> runParsec m2 ok err inp exp) inp exp)++instance Applicative (Parsec a) where+  {-# INLINE pure #-}+  pure = return+  {-# INLINE (<*>) #-}+  f <*> x = do { f' <- f; x' <- x; return (f' x') }+  {-# INLINE (*>) #-}+  (*>) = (>>)+  {-# INLINE (<*) #-}+  x <* y = do+    x' <- x+    y+    return x'++instance Alternative (Parsec a) where+  {-# INLINE empty #-}+  empty = mzero+  {-# INLINE (<|>) #-}+  (<|>) = mplus+  {-# INLINE some #-}+  some p = do { x <- nonempty p; xs <- many p; return (x:xs) }+  {-# INLINE many #-}+  many p = p' where p' = liftM2 (:) (nonempty p) p' <|> return []+  -- Stack overflow-avoiding version:+  -- many p = liftM reverse (p' [])+  --   where p' !xs = do { x <- nonempty p; p' (x:xs) } `mplus` return xs++-- Basic combinators++{-# INLINE nonempty #-}+nonempty :: Parsec a b -> Parsec a b+nonempty p = p++{-# INLINE skipSome #-}+skipSome :: Parsec a b -> Parsec a ()+skipSome p = p' where p' = nonempty p >> (p' `mplus` return ())++{-# INLINE skipMany #-}+skipMany :: Parsec a b -> Parsec a ()+skipMany p = p' where p' = (nonempty p >> p') `mplus` return ()++{-# INLINE (<?>) #-}+infix 0 <?>+(<?>) :: Parsec a b -> String -> Parsec a b+p <?> text = Parsec (\ok err inp exp ->+  runParsec p ok err inp (text:exp))++{-# INLINE between #-}+between :: Parsec a b -> Parsec a c -> Parsec a d -> Parsec a d+between p q r = p *> r <* q++{-# INLINE sepBy1 #-}+sepBy1 :: Parsec a b -> Parsec a c -> Parsec a [b]+sepBy1 it sep = liftM2 (:) it (many (sep >> it))++-- Running the parser++run_ :: Stream a c => Parsec a b -> a -> Result (Position a) b+run_ p x = runParsec p ok err x []+  where ok x _ inp _ = Ok (position inp) x+        err exp = Expected (position x) (reverse exp)++run :: Stream a c => (Position a -> [String]) -> Parsec a b -> a -> (Position a, Either [String] b)+run report p ts =+  case run_ p ts of+    Ok ts' x -> (ts', Right x)+    Error ts' e -> (ts', Left [e])+    Expected ts' e -> (ts', Left (expected (report ts') e))++-- Reporting errors++expected :: [String] -> [String] -> [String]+expected unexpected [] = unexpected ++ ["Unknown error"]+expected unexpected expected =+  unexpected ++ [ "Expected " ++ list expected ]+  where list [exp] = exp+        list exp = intercalate ", " (init exp) ++ " or " ++ last exp++-- Token streams++class Stream a b | a -> b where+  primToken :: a -> (a -> b -> c) -> c -> (String -> c) -> c+  type Position a+  position :: a -> Position a++{-# INLINE next #-}+next :: Stream a b => Parsec a b+next = Parsec (\ok err inp exp ->+  primToken inp (\inp' x -> ok x err inp' exp) (err exp) (Error (position inp)))++{-# INLINE cut #-}+cut :: Stream a b => Parsec a ()+cut = Parsec (\ok _err inp _exp -> ok () (Expected (position inp)) inp [])++{-# INLINE cut' #-}+cut' :: Stream a b => Parsec a c -> Parsec a c+cut' p = Parsec (\ok err inp exp -> runParsec p (\x _ inp' _ -> ok x err inp' []) err inp exp)++{-# INLINE satisfy #-}+satisfy :: Stream a b => (b -> Bool) -> Parsec a b+satisfy p = do+  t <- next+  guard (p t)+  cut+  return t++{-# INLINE eof #-}+eof :: Stream a b => Parsec a ()+eof = Parsec (\ok err inp exp ->+  primToken inp (\_ _ -> err ("end of file":exp)) (ok () err inp exp) (Error (position inp)))++-- User state++data UserState state stream = UserState { userState :: !state, userStream :: !stream }++instance Stream a b => Stream (UserState state a) b where+  {-# INLINE primToken #-}+  primToken (UserState state stream) ok err =+    primToken stream (ok . UserState state) err+  type Position (UserState state a) = UserState state a+  position = id++{-# INLINE getState #-}+getState :: Parsec (UserState state a) state+getState = Parsec (\ok err inp@UserState{userState = state} exp -> ok state err inp exp)++{-# INLINE putState #-}+putState :: state -> Parsec (UserState state a) ()+putState state = Parsec (\ok err UserState{userStream = stream} exp -> ok () err (UserState state stream) exp)
+ src/Jukebox/TPTP/Print.hs view
@@ -0,0 +1,244 @@+-- Pretty-printing of formulae. WARNING: icky code inside!+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, TypeOperators, FlexibleInstances, CPP, GADTs #-}+module Jukebox.TPTP.Print(prettyShow, showClauses, pPrintClauses, showProblem, pPrintProblem)+       where++#include "errors.h"+import Data.Char+import Text.PrettyPrint.HughesPJ+import qualified Jukebox.TPTP.Lexer as L+import Jukebox.Form+import qualified Data.Map.Strict as Map+import Data.Map(Map)+import qualified Data.Set as Set+import Data.Set(Set)+import Jukebox.Name+import Jukebox.Utils+import Text.PrettyPrint.HughesPJClass+import Data.Symbol++pPrintClauses :: Problem Clause -> Doc+pPrintClauses prob0+  | isFof prob = vcat (map (pPrintInput "cnf" pPrint) prob)+  | otherwise  = pPrintProblem (map (fmap toForm) prob0)+  where+    prob = prettyNames prob0++showClauses :: Problem Clause -> String+showClauses = show . pPrintClauses++pPrintProblem :: Problem Form -> Doc+pPrintProblem prob0+  | isReallyFof prob = vcat (map (pPrintInput "fof" (pPrintFof 0)) prob)+  | otherwise = vcat (pPrintDecls prob ++ map (pPrintInput "tff" (pPrintTff 0)) prob)+  where+    prob = prettyNames prob0++showProblem :: Problem Form -> String+showProblem = show . pPrintProblem++isReallyFof :: Symbolic a => a -> Bool+isReallyFof = all p . types+  where+    p O = True+    p (Type ty _ _) | ty == i = True+    p _ = False+    i = name "$i"++pPrintDecls :: Problem Form -> [Doc]+pPrintDecls prob =+  map typeDecl (usort (types prob)) +++  map funcDecl (usort (functions prob))+  where+    typeDecl O = empty+    typeDecl (Type ty _ _) | ty == i = empty+    typeDecl ty = typeClause ty (text "$tType")+    i = name "$i"++    funcDecl (f ::: ty) = typeClause f (pPrint ty)+    typeClause name ty =+      pPrintClause "tff" "type" "type"+        (pPrint name <> colon <+> ty)++instance Pretty a => Pretty (Input a) where+  pPrint = pPrintInput "tff" pPrint+instance Pretty a => Show (Input a) where+  show = prettyShow++pPrintInput :: String -> (a -> Doc) -> Input a -> Doc+pPrintInput family pp i =+  pPrintClause family (tag i) (show (kind i)) (pp (what i))++pPrintClause :: String -> String -> String -> Doc -> Doc+pPrintClause family name kind rest =+  text family <> parens (sep [text name <> comma <+> text kind <> comma, rest]) <> text "."++instance Pretty Clause where+  pPrint (Clause (Bind _ ts)) =+    pPrintConnective undefined 0 "$false" "|" (map Literal ts)++instance Show Clause where+  show = prettyShow++instance Pretty Type where+  pPrint O = text "$o"+  pPrint ty = text . escapeAtom . show . tname $ ty++instance Show Type where+  show = prettyShow++instance Pretty FunType where+  pPrint FunType{args = args, res = res} =+    case args of+      [] -> pPrint res+      args -> pPrintTypes args <+> text ">" <+>+              pPrint res+    where+      pPrintTypes [arg] = pPrint arg+      pPrintTypes args =+        parens . hsep . punctuate (text " *") . map pPrint $ args++instance Show FunType where+  show = prettyShow++instance Pretty Name where+  pPrint = text . show++instance Show L.Token where+  show L.Atom{L.tokenName = x} = escapeAtom x+  show L.Defined{L.defined = x} = show x+  show L.Var{L.tokenName = x} = x+  show L.DistinctObject{L.tokenName = x} = quote '"' x+  show L.Number{L.value = x} = show x+  show L.Punct{L.kind = x} = show x+  show L.Eof = "end of file"+  show L.Error = "lexical error"++escapeAtom :: String -> String+escapeAtom s | not (null s') && isLower (head s') && all isNormal s' = s+             | otherwise = quote '\'' s+  where isNormal c = isAlphaNum c || c == '_'+        s' = dropWhile (== '$') s++quote :: Char -> String -> String+quote c s = [c] ++ concatMap escape s ++ [c]+  where escape c' | c == c' = ['\\', c]+        escape '\\' = "\\\\"+        escape c = [c]++instance Pretty Term where+  pPrint (Var (v ::: _)) =+    pPrint v+  pPrint ((f ::: _) :@: []) =+    text (escapeAtom (show f))+  pPrint ((f ::: _) :@: ts) =+    text (escapeAtom (show f)) <>+    parens (sep (punctuate comma (map pPrint ts)))++instance Show Term where+  show = prettyShow++instance Pretty Atomic where+  pPrint (t :=: u) = pPrint t <> text "=" <> pPrint u+  pPrint (Tru t) = pPrint t++instance Show Atomic where+  show = prettyShow++instance Pretty Form where+  pPrintPrec _ = pPrintTff++instance Show Form where+  show = prettyShow++pPrintFof, pPrintTff :: Rational -> Form -> Doc+pPrintFof = pPrintForm (\(x ::: _) -> pPrint x)+pPrintTff = pPrintForm (\(x ::: ty) -> pPrint x <> colon <+> pPrint ty)++pPrintForm :: (Variable -> Doc) -> Rational -> Form -> Doc+-- We use two precedences, the lowest for binary connectives+-- and the highest for everything else.+pPrintForm _bind _p (Literal (Pos (t :=: u))) =+  pPrint t <> text "=" <> pPrint u+pPrintForm _bind _p (Literal (Neg (t :=: u))) =+  pPrint t <> text "!=" <> pPrint u+pPrintForm _bind p (Literal (Pos t)) = pPrintPrec prettyNormal p t+pPrintForm bind p (Literal (Neg t)) = pPrintForm bind p (Not (Literal (Pos t)))+pPrintForm bind _p (Not f) = text "~" <> pPrintForm bind 1 f+pPrintForm bind p (And ts) = pPrintConnective bind p "$true" "&" ts+pPrintForm bind p (Or ts) = pPrintConnective bind p "$false" "|" ts+pPrintForm bind p (Equiv t u) = pPrintConnective bind p undefined "<=>" [t, u]+pPrintForm bind _p (ForAll (Bind vs f)) = pPrintQuant bind "!" vs f+pPrintForm bind _p (Exists (Bind vs f)) = pPrintQuant bind "?" vs f+pPrintForm bind p (Connective c t u) = pPrintConnective bind p (error "pPrint: Connective") (show c) [t, u]++instance Show Connective where+  show Implies = "=>"+  show Follows = "<="+  show Xor = "<~>"+  show Nor = "~|"+  show Nand = "~&"++pPrintConnective _bind _p ident _op [] = text ident+pPrintConnective bind p _ident _op [x] = pPrintForm bind p x+pPrintConnective bind p _ident op (x:xs) =+  maybeParens (p > 0) $+    sep (ppr x:[ nest 2 (text op <+> ppr x) | x <- xs ])+      where ppr = pPrintForm bind 1+            +pPrintQuant :: (Variable -> Doc) -> String -> Set.Set Variable -> Form -> Doc+pPrintQuant bind q vs f+  | Set.null vs = pPrintForm bind 1 f+  | otherwise =+    sep [+      text q <> brackets (sep (punctuate comma (map bind (Set.toList vs)))) <> colon,+      nest 2 (pPrintForm bind 1 f)]++instance Show Kind where+  show Axiom = "axiom"+  show Conjecture = "conjecture"+  show Question = "question"++prettyNames :: Symbolic a => a -> a+prettyNames x0 = mapName replace x+  where+    replace name@Fixed{}  = name+    replace name@Unique{} = Map.findWithDefault __ name sub++    sub = globalsScope `Map.union` pretty globalsUsed x++    pretty :: Symbolic a => Set String -> a -> Map Name Name+    pretty used x =+      case typeOf x of+        Bind_ -> bind used x+        _ -> collect (pretty used) x++    bind :: Symbolic a => Set String -> Bind a -> Map Name Name+    bind used (Bind vs x) =+      scope `Map.union` pretty used' x+      where+        (scope, used') = add used (map name (Set.toList vs))++    add used names =+      foldr add1 (Map.empty, used) names++    add1 (Fixed xs) (scope, used) =+      (scope, Set.insert (unintern xs) used)+    add1 name@(Unique _ base f) (scope, used) =+      (Map.insert name (Fixed (intern winner)) scope,+       Set.insert winner (Set.fromList taken `Set.union` used))+      where+        cands = [f base n | n <- [0..]]+        Renaming taken winner =+          head [c | c@(Renaming xs x) <- cands,+                not (or [Set.member y used | y <- x:xs ])]++    globals =+      usort $+        [ f | f ::: _ <- functions x ] +++        [ ty | Type ty _ _ <- types x ]+    (globalsScope, globalsUsed) = add fixed globals++    fixed = Set.fromList [ unintern xs | Fixed xs <- names x ]++    x = run x0 uniqueNames
+ src/Jukebox/Toolbox.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE RecordWildCards #-}+module Jukebox.Toolbox where++import Jukebox.Options+import Jukebox.Form+import Jukebox.Name+import Jukebox.TPTP.Print+import Control.Monad+import Jukebox.Clausify hiding (run)+import Jukebox.TPTP.Parse+import Jukebox.Monotonox.Monotonicity hiding (guards)+import Jukebox.Monotonox.ToFOF+import System.Exit+import System.IO+import Jukebox.TPTP.FindFile+import Jukebox.GuessModel+import Jukebox.InferTypes+import qualified Data.Map.Strict as Map++data GlobalFlags =+  GlobalFlags {+    quiet :: Bool }+  deriving Show++globalFlags :: OptionParser GlobalFlags+globalFlags =+  inGroup "Global options" $+  GlobalFlags <$>+    bool "quiet"+      ["Do not print any informational output.",+       "Default: (off)"]++(=>>=) :: (Monad m, Applicative f) => f (a -> m b) -> f (b -> m c) -> f (a -> m c)+f =>>= g = (>=>) <$> f <*> g+infixl 1 =>>= -- same as >=>++(=>>) :: (Monad m, Applicative f) => f (m a) -> f (m b) -> f (m b)+x =>> y = (>>) <$> x <*> y+infixl 1 =>> -- same as >>++greetingBox :: Tool -> OptionParser (IO ())+greetingBox t = greetingBoxIO t <$> globalFlags++greetingBoxIO :: Tool -> GlobalFlags -> IO ()+greetingBoxIO t GlobalFlags{quiet = quiet} =+  unless quiet $ hPutStrLn stderr (greeting t)++allFilesBox :: OptionParser ((FilePath -> IO ()) -> IO ())+allFilesBox = flip allFiles <$> filenames++allFiles :: (FilePath -> IO ()) -> [FilePath] -> IO ()+allFiles _ [] = do+  hPutStrLn stderr "No input files specified! Try --help."+  exitWith (ExitFailure 1)+allFiles f xs = mapM_ f xs++parseProblemBox :: OptionParser (FilePath -> IO (Problem Form))+parseProblemBox = parseProblemIO <$> findFileFlags++parseProblemIO :: [FilePath] -> FilePath -> IO (Problem Form)+parseProblemIO dirs f = do+  r <- parseProblem dirs f+  case r of+    Left err -> do+      hPutStrLn stderr err+      exitWith (ExitFailure 1)+    Right x -> return x++clausifyBox :: OptionParser (Problem Form -> IO CNF)+clausifyBox = clausifyIO <$> globalFlags <*> clausifyFlags++clausifyIO :: GlobalFlags -> ClausifyFlags -> Problem Form -> IO CNF+clausifyIO globals flags prob = do+  unless (quiet globals) $ hPutStrLn stderr "Clausifying problem..."+  return $! clausify flags prob++toFofBox :: OptionParser (Problem Form -> IO (Problem Form))+toFofBox = toFofIO <$> globalFlags <*> clausifyBox <*> schemeBox++oneConjectureBox :: OptionParser (CNF -> IO (Problem Clause))+oneConjectureBox = pure oneConjecture++oneConjecture :: CNF -> IO (Problem Clause)+oneConjecture cnf = run cnf f+  where f (CNF cs [cs'] _ _) = return (return (cs ++ cs'))+        f _ = return $ do+          hPutStrLn stderr "Error: more than one conjecture found in input problem"+          exitWith (ExitFailure 1)++toFofIO :: GlobalFlags -> (Problem Form -> IO CNF) -> Scheme -> Problem Form -> IO (Problem Form)+toFofIO globals clausify scheme f = do+  cs <- clausify f >>= oneConjecture+  unless (quiet globals) $ hPutStrLn stderr "Monotonicity analysis..."+  m <- monotone (map what cs)+  let isMonotone ty =+        case Map.lookup ty m of+          Just Nothing -> False+          Just (Just _) -> True+          Nothing  -> True -- can happen if clausifier removed all clauses about a type+  return (translate scheme isMonotone f)++schemeBox :: OptionParser Scheme+schemeBox =+  choose <$>+  flag "encoding"+    ["Which type encoding to use.",+     "Default: --encoding guards"]+    "guards"+    (argOption ["guards", "tags"])+  <*> tagsFlags+  where choose "guards" _flags = guards+        choose "tags" flags = tags flags++monotonicityBox :: OptionParser (Problem Clause -> IO String)+monotonicityBox = monotonicity <$> globalFlags++monotonicity :: GlobalFlags -> Problem Clause -> IO String+monotonicity globals cs = do+  unless (quiet globals) $ hPutStrLn stderr "Monotonicity analysis..."+  m <- monotone (map what cs)+  let info (ty, Nothing) = [base ty ++ ": not monotone"]+      info (ty, Just m) =+        [prettyShow ty ++ ": monotone"] +++        concat+        [ case ext of+             CopyExtend -> []+             TrueExtend -> ["  " ++ base p ++ " true-extended"]+             FalseExtend -> ["  " ++ base p ++ " false-extended"]+        | (p, ext) <- Map.toList m ]++  return (unlines (concat (map info (Map.toList m))))++annotateMonotonicityBox :: OptionParser (Problem Clause -> IO (Problem Clause))+annotateMonotonicityBox = (\globals x -> do+  unless (quiet globals) $ putStrLn "Monotonicity analysis..."+  annotateMonotonicity x) <$> globalFlags++prettyPrintProblemBox :: OptionParser (Problem Form -> IO ())+prettyPrintProblemBox = prettyPrintIO showProblem <$> globalFlags <*> writeFileBox++prettyPrintClausesBox :: OptionParser (Problem Clause -> IO ())+prettyPrintClausesBox = prettyPrintIO showClauses <$> globalFlags <*> writeFileBox++prettyPrintIO :: (a -> String) -> GlobalFlags -> (String -> IO ()) -> a -> IO ()+prettyPrintIO shw globals write prob = do+  unless (quiet globals) $ hPutStrLn stderr "Writing output..."+  write (shw prob ++ "\n")++writeFileBox :: OptionParser (String -> IO ())+writeFileBox =+  flag "output"+    ["Where to write the output.",+     "Default: stdout"]+    putStr+    (fmap myWriteFile argFile)+  where myWriteFile "/dev/null" _ = return ()+        myWriteFile file contents = writeFile file contents++guessModelBox :: OptionParser (Problem Form -> IO (Problem Form))+guessModelBox = guessModelIO <$> expansive <*> universe+  where universe = choose <$>+                   flag "universe"+                   ["Which universe to find the model in.",+                    "Default: peano"]+                   "peano"+                   (argOption ["peano", "trees"])+        choose "peano" = Peano+        choose "trees" = Trees+        expansive = manyFlags "expansive"+                    ["Allow a function to construct 'new' terms in its base base."]+                    (arg "<function>" "expected a function name" Just)++guessModelIO :: [String] -> Universe -> Problem Form -> IO (Problem Form)+guessModelIO expansive univ prob = return (guessModel expansive univ prob)++allObligsBox :: OptionParser ((Problem Clause -> IO Answer) -> CNF -> IO ())+allObligsBox = pure allObligsIO++allObligsIO solve CNF{..} = loop 1 conjectures+  where loop _ [] = result unsatisfiable+        loop i (c:cs) = do+          when multi $ putStrLn $ "Part " ++ part i+          answer <- solve (axioms ++ c)+          when multi $ putStrLn $ "+++ PARTIAL (" ++ part i ++ "): " ++ show answer+          case answer of+            Satisfiable -> result satisfiable+            Unsatisfiable -> loop (i+1) cs+            NoAnswer x -> result (show x)+        multi = length conjectures > 1+        part i = show i ++ "/" ++ show (length conjectures)+        result x = putStrLn ("+++ RESULT: " ++ x)++inferBox :: OptionParser (Problem Clause -> IO (Problem Clause, Type -> Type))+inferBox = (\globals prob -> do+  unless (quiet globals) $ putStrLn "Inferring types..."+  return (run prob inferTypes)) <$> globalFlags++printInferredBox :: OptionParser ((Problem Clause, Type -> Type) -> IO (Problem Clause))+printInferredBox = pure $ \(prob, rep) -> do+  forM_ (types prob) $ \ty ->+    putStrLn $ show ty ++ " => " ++ show (rep ty)+  return prob
+ src/Jukebox/UnionFind.hs view
@@ -0,0 +1,76 @@+module Jukebox.UnionFind(UF, Replacement((:>)), (=:=), rep, evalUF, execUF, runUF, S, isRep, initial, reps) where++import Prelude hiding (min)+import Control.Monad+import Control.Monad.Trans.State.Strict+import Data.Map.Strict(Map)+import qualified Data.Map as Map++type S a = Map a a+type UF a = State (S a)+data Replacement a = a :> a++runUF :: S a -> UF a b -> (b, S a)+runUF s m = runState m s++evalUF :: S a -> UF a b -> b+evalUF s m = fst (runUF s m)++execUF :: S a -> UF a b -> S a+execUF s m = snd (runUF s m)++initial :: S a+initial = Map.empty++(=:=) :: Ord a => a -> a -> UF a (Maybe (Replacement a))+s =:= t | s == t = return Nothing+s =:= t = do+  rs <- rep s+  rt <- rep t+  case rs `compare` rt of+    EQ -> return Nothing+    LT -> do+      modify (Map.insert rt rs)+      return (Just (rt :> rs))+    GT -> do+      modify (Map.insert rs rt)+      return (Just (rs :> rt))++{-# INLINE rep #-}+rep :: Ord a => a -> UF a a+rep s = do+  m <- get+  case Map.lookup s m of+    Nothing -> return s+    Just t -> do+      u <- rep t+      when (t /= u) $ modify (Map.insert s u)+      return u+      -- case Map.lookup t m of+      --   Nothing -> return t+      --   Just u -> do+      --     v <- rep' t u+      --     modify (Map.insert s v)+      --     return v++reps :: Ord a => UF a (a -> a)+reps = do+  s <- get+  return (\x -> evalUF s (rep x))++-- rep' :: Ord a => a -> a -> UF a a+-- rep' s t = do+--   m <- get+--   case Map.lookup t m of+--     Nothing -> do+--       modify (Map.insert s t)+--       return t+--     Just u -> do+--       v <- rep' t u+--       modify (Map.insert s v)+--       return v++isRep :: Ord a => a -> UF a Bool+isRep t = do+  t' <- rep t+  return (t == t')
+ src/Jukebox/Utils.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TupleSections #-}+module Jukebox.Utils where++import System.Process+import System.IO+import System.Exit+import Control.Concurrent+import qualified Data.Set as Set++usort :: Ord a => [a] -> [a]+--usort = map head . group . sort+usort = Set.toAscList . Set.fromList++merge :: Ord a => [a] -> [a] -> [a]+merge [] ys = ys+merge xs [] = xs+merge (x:xs) (y:ys) =+  case x `compare` y of+    LT -> x:merge xs (y:ys)+    EQ -> x:merge xs ys+    GT -> y:merge (x:xs) ys++popen :: FilePath -> [String] -> String -> IO (ExitCode, String)+popen prog args inp = do+  (stdin, stdout, stderr_, pid) <- runInteractiveProcess prog args Nothing Nothing+  forkIO $ hGetContents stderr_ >>= hPutStr stderr+  hPutStr stdin inp+  hFlush stdin+  hClose stdin+  code <- waitForProcess pid+  fmap (code,) (hGetContents stdout) <* hClose stdout