### Libraries AllSolutions, Combinatorial, Findall, Random, SearchTree*,...

`Libraries AllSolutions, Combinatorial, Findall, Random, SearchTree*, SetFunctions, Traversal ValueSequence removed (available in packages)`
parent 2aa68cf1
 ------------------------------------------------------------------------------ --- A collection of common non-deterministic and/or combinatorial operations. --- Many operations are intended to operate on sets. --- The representation of these sets is not hidden; rather --- sets are represented as lists. --- Ideally these lists contains no duplicate elements and --- the order of their elements cannot be observed. --- In practice, these conditions are not enforced. --- --- @author Sergio Antoy (with extensions by Michael Hanus) --- @version April 2016 --- @category general ------------------------------------------------------------------------------ module Combinatorial(permute, subset, allSubsets, splitSet, sizedSubset, partition) where import List(sum) import SetFunctions import Test.Prop ------------------------------------------------------------------------------ -- Public Operations ------------------------------------------------------------------------------ --- Compute any permutation of a list. --- --- @param xs - The list. --- @return A permutation of the argument. permute :: [a] -> [a] permute [] = [] permute (x:xs) = ndinsert (permute xs) where ndinsert [] = [x] ndinsert (y:ys) = (x:y:ys) ? (y:ndinsert ys) -- Properties: permute1234 = permute [1,2,3,4] ~> [1,3,4,2] -- The length of a permutation is identical to the length of the argument: permLength xs = length (permute xs) <~> length xs -- lengths are equal -- The permutation contains the same elements as the argument: permElems xs = anyOf (permute xs) <~> anyOf xs ------------------------------------------------------------------------------ --- Compute any sublist of a list. --- The sublist contains some of the elements of the list in the same order. --- --- @param xs - The list. --- @return A sublist of the argument. subset :: [a] -> [a] subset [] = [] subset (x:xs) = x:subset xs subset (_:xs) = subset xs -- Properties: subset1234 = subset [1,2,3,4] ~> [1,3] subset123 = subset [1,2,3] <~> ([1,2,3]?[1,2]?[1,3]??[2,3]???[]) subsetElems xs = anyOf (subset xs) <~ anyOf xs ------------------------------------------------------------------------------ --- Compute all the sublists of a list. --- --- @param xs - The list. --- @return All the sublists of the argument. allSubsets :: Ord a => [a] -> [[a]] allSubsets xs = sortValues (set1 subset xs) -- Properties: allSubsets123 = allSubsets [1,2,3] -=- [[],,[1,2],[1,2,3],[1,3],,[2,3],] ------------------------------------------------------------------------------ --- Split a list into any two sublists. --- --- @param xs - The list. --- @return A pair consisting of two complementary sublists of the argument. splitSet :: [a] -> ([a],[a]) splitSet [] = ([],[]) splitSet (x:xs) = let (u,v) = splitSet xs in (x:u,v) ? (u,x:v) -- Properties: splitSet1234 = splitSet [1,2,3,4] ~> ([1,3,4],) -- The sum of the length of the two sublists is the length of the argument list: splitSetLengths xs = (\ (xs,ys) -> length xs + length ys) (splitSet xs) <~> length xs -- The two sublists and the argument list have the same elements: splitSetElems xs = (\ (xs,ys) -> anyOf xs ? anyOf ys) (splitSet xs) <~> anyOf xs ------------------------------------------------------------------------------ --- Compute any sublist of fixed length of a list. --- Similar to 'subset', but the length of the result is fixed. --- --- @param c - The length of the output sublist. --- @param xs - The input list. --- @return A sublist of `xs` of length `c`. sizedSubset :: Int -> [a] -> [a] sizedSubset c l = if c == 0 then [] else aux l where aux (x:xs) = x:sizedSubset (c-1) xs ? sizedSubset c xs -- Precondition: sizedSubset'pre c _ = c>=0 -- Properties: sizedSubsetLength c xs = (c>=0 && length xs >= c) ==> length (sizedSubset c xs) <~> c -- No result if the given output length is larger than the length of the input: sizedSubsetLengthTooSmall c xs = (c>=0 && length xs < c) ==> failing (sizedSubset c xs) ------------------------------------------------------------------------------ --- Compute any partition of a list. --- The output is a list of non-empty lists such that their concatenation --- is a permutation of the input list. --- No guarantee is made on the order of the arguments in the output. --- --- @param xs - The input list. --- @return A partition of `xs` represented as a list of lists. partition :: [a] -> [[a]] partition [] = [] partition (x:xs) = insert x (partition xs) where insert e [] = [[e]] insert e (y:ys) = ((e:y):ys) ? (y:insert e ys) -- Properties: partition1234 = partition [1,2,3,4] ~> [,[2,3],] partition123 = partition [1,2,3] <~> ([[1,2,3]] ? [[2,3],] ? [[1,3],] ? [,[1,2]] ? [,,]) -- The sum of the length of the sublists is the length of the argument list: partitionLengths xs = sum (map length (partition xs)) <~> length xs -- The sublists of the partition and the argument list have the same elements: partitionElems xs = anyOf (map anyOf (partition xs)) <~> anyOf xs -- end module Combinatorial
 ------------------------------------------------------------------------------ --- Library with some operations for encapsulating search. --- Note that some of these operations are not fully declarative, --- i.e., the results depend on the order of evaluation and program rules. --- There are newer and better approaches the encapsulate search, --- in particular, set functions (see module `SetFunctions`), --- which should be used. --- --- In previous versions of PAKCS, some of these operations were part of --- the standard prelude. We keep them in this separate module --- in order to support a more portable standard prelude. --- --- @author Michael Hanus --- @version September 2018 --- @category general ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Findall ( getAllValues, getSomeValue , allValues, someValue, oneValue , allSolutions, someSolution , isFail #ifdef __PAKCS__ , try, inject, solveAll, once, best , findall, findfirst, browse, browseList, unpack , rewriteAll, rewriteSome #endif ) where #ifdef __PAKCS__ #else import qualified SearchTree as ST #endif --- Gets all values of an expression (currently, via an incomplete --- depth-first strategy). Conceptually, all values are computed --- on a copy of the expression, i.e., the evaluation of the expression --- does not share any results. In PAKCS, the evaluation suspends --- as long as the expression contains unbound variables. --- Similar to Prolog's findall. getAllValues :: a -> IO [a] getAllValues e = return (allValues e) --- Gets a value of an expression (currently, via an incomplete --- depth-first strategy). The expression must have a value, otherwise --- the computation fails. Conceptually, the value is computed on a copy --- of the expression, i.e., the evaluation of the expression does not share --- any results. In PAKCS, the evaluation suspends as long as the expression --- contains unbound variables. getSomeValue :: a -> IO a getSomeValue e = return (someValue e) --- Returns all values of an expression (currently, via an incomplete --- depth-first strategy). Conceptually, all values are computed on a copy --- of the expression, i.e., the evaluation of the expression does not share --- any results. In PAKCS, the evaluation suspends as long as the expression --- contains unbound variables. --- --- Note that this operation is not purely declarative since the ordering --- of the computed values depends on the ordering of the program rules. allValues :: a -> [a] #ifdef __PAKCS__ allValues external #else allValues e = ST.allValuesDFS (ST.someSearchTree e) #endif --- Returns some value for an expression (currently, via an incomplete --- depth-first strategy). If the expression has no value, the --- computation fails. Conceptually, the value is computed on a copy --- of the expression, i.e., the evaluation of the expression does not share --- any results. In PAKCS, the evaluation suspends as long as the expression --- contains unbound variables. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. someValue :: a -> a #ifdef __PAKCS__ someValue external #else someValue = ST.someValueWith ST.dfsStrategy #endif --- Returns just one value for an expression (currently, via an incomplete --- depth-first strategy). If the expression has no value, `Nothing` --- is returned. Conceptually, the value is computed on a copy --- of the expression, i.e., the evaluation of the expression does not share --- any results. In PAKCS, the evaluation suspends as long as the expression --- contains unbound variables. --- --- Note that this operation is not purely declarative since --- the computed value depends on the ordering of the program rules. --- Thus, this operation should be used only if the expression --- has a single value. oneValue :: a -> Maybe a #ifdef __PAKCS__ oneValue external #else oneValue x = let vals = ST.allValuesWith ST.dfsStrategy (ST.someSearchTree x) in (if null vals then Nothing else Just (head vals)) #endif --- Returns all values satisfying a predicate, i.e., all arguments such that --- the predicate applied to the argument can be evaluated to `True` --- (currently, via an incomplete depth-first strategy). --- In PAKCS, the evaluation suspends as long as the predicate expression --- contains unbound variables. --- --- Note that this operation is not purely declarative since the ordering --- of the computed values depends on the ordering of the program rules. allSolutions :: (a->Bool) -> [a] #ifdef __PAKCS__ allSolutions p = findall (\x -> p x =:= True) #else allSolutions p = allValues (let x free in p x &> x) #endif --- Returns some values satisfying a predicate, i.e., some argument such that --- the predicate applied to the argument can be evaluated to `True` --- (currently, via an incomplete depth-first strategy). --- If there is no value satisfying the predicate, the computation fails. --- --- Note that this operation is not purely declarative since the ordering --- of the computed values depends on the ordering of the program rules. --- Thus, this operation should be used only if the --- predicate has a single solution. someSolution :: (a->Bool) -> a #ifdef __PAKCS__ someSolution p = findfirst (\x -> p x =:= True) #else someSolution p = someValue (let x free in p x &> x) #endif --- Does the computation of the argument to a head-normal form fail? --- Conceptually, the argument is evaluated on a copy, i.e., --- even if the computation does not fail, it has not been evaluated. isFail :: a -> Bool #ifdef __PAKCS__ isFail external #else isFail x = null (allValues (x `seq` ())) #endif #ifdef __PAKCS__ ------------------------------------------------------------------------------ --- Basic search control operator. try :: (a -> Bool) -> [a -> Bool] try external --- Inject operator which adds the application of the unary --- procedure p to the search variable to the search goal --- taken from Oz. p x comes before g x to enable a test+generate --- form in a sequential implementation. inject :: (a -> Bool) -> (a -> Bool) -> (a -> Bool) inject g p = \x -> p x & g x --- Computes all solutions via a a depth-first strategy. -- -- Works as the following algorithm: -- -- solveAll g = evalResult (try g) -- where -- evalResult [] = [] -- evalResult [s] = [s] -- evalResult (a:b:c) = concatMap solveAll (a:b:c) -- -- The following solveAll algorithm is faster. -- For comparison we have solveAll2, which implements the above algorithm. solveAll :: (a -> Bool) -> [a -> Bool] solveAll g = evalall (try g) where evalall [] = [] evalall [a] = [a] evalall (a:b:c) = evalall3 (try a) (b:c) evalall2 [] = [] evalall2 (a:b) = evalall3 (try a) b evalall3 [] b = evalall2 b evalall3 [l] b = l : evalall2 b evalall3 (c:d:e) b = evalall3 (try c) (d:e ++b) solveAll2 :: (a -> Bool) -> [a -> Bool] solveAll2 g = evalResult (try g) where evalResult [] = [] evalResult [s] = [s] evalResult (a:b:c) = concatMap solveAll2 (a:b:c) --- Gets the first solution via a depth-first strategy. once :: (a -> Bool) -> (a -> Bool) once g = head (solveAll g) --- Gets the best solution via a depth-first strategy according to --- a specified operator that can always take a decision which --- of two solutions is better. --- In general, the comparison operation should be rigid in its arguments! best :: (a -> Bool) -> (a -> a -> Bool) -> [a -> Bool] best g cmp = bestHelp [] (try g) [] where bestHelp [] [] curbest = curbest bestHelp [] (y:ys) curbest = evalY (try (constrain y curbest)) ys curbest bestHelp (x:xs) ys curbest = evalX (try x) xs ys curbest evalY [] ys curbest = bestHelp [] ys curbest evalY [newbest] ys _ = bestHelp [] ys [newbest] evalY (c:d:xs) ys curbest = bestHelp (c:d:xs) ys curbest evalX [] xs ys curbest = bestHelp xs ys curbest evalX [newbest] xs ys _ = bestHelp [] (xs++ys) [newbest] evalX (c:d:e) xs ys curbest = bestHelp ((c:d:e)++xs) ys curbest constrain y [] = y constrain y [curbest] = inject y (\v -> let w free in curbest w & cmp v w =:= True) --- Gets all solutions via a depth-first strategy and unpack --- the values from the lambda-abstractions. --- Similar to Prolog's findall. findall :: (a -> Bool) -> [a] findall external --- Gets the first solution via a depth-first strategy --- and unpack the values from the search goals. findfirst :: (a -> Bool) -> a findfirst external --- Shows the solution of a solved constraint. browse :: Show a => (a -> Bool) -> IO () browse g = putStr (show (unpack g)) --- Unpacks solutions from a list of lambda abstractions and write --- them to the screen. browseList :: Show a => [a -> Bool] -> IO () browseList [] = done browseList (g:gs) = browse g >> putChar '\n' >> browseList gs --- Unpacks a solution's value from a (solved) search goal. unpack :: (a -> Bool) -> a unpack g | g x = x where x free --- Gets all values computable by term rewriting. --- In contrast to `findall`, this operation does not wait --- until all "outside" variables are bound to values, --- but it returns all values computable by term rewriting --- and ignores all computations that requires bindings for outside variables. rewriteAll :: a -> [a] rewriteAll external --- Similarly to 'rewriteAll' but returns only some value computable --- by term rewriting. Returns `Nothing` if there is no such value. rewriteSome :: a -> Maybe a rewriteSome external #endif
 prim_standard prim_allValues[raw] prim_standard prim_someValue[raw] prim_standard prim_oneValue[raw] prim_standard prim_findall[raw] prim_standard prim_findfirst[raw] prim_standard prim_isFail[raw] prim_standard prim_try[raw] prim_standard prim_rewriteAll[raw] prim_standard prim_rewriteSome[raw]
This diff is collapsed.