Commit cedc5de1 authored by Michael Hanus 's avatar Michael Hanus

Support for using default rules and set functions in service execs added

parent ab650b3a
{
"name": "Smap",
"version": "1.0.0",
"author": "YOUR NAME <YOUR EMAIL ADDRESS>",
"author": "Lasse Kristopher Meyer, Michael Hanus <mh@informatik.uni-kiel.de>",
"maintainer": "Michael Hanus <mh@informatik.uni-kiel.de>",
"synopsis": "Web application 'Smap' generated by Spicey",
"category": [ "Web" ],
"dependencies": {
......@@ -15,8 +16,8 @@
"wui" : ">= 2.0.0"
},
"compilerCompatibility": {
"pakcs": ">= 2.0.0",
"kics2": ">= 2.0.0"
"pakcs": ">= 2.0.0, < 3.0.0",
"kics2": ">= 2.0.0, < 3.0.0"
},
"sourceDirs": [ "src", "src/Model" ]
}
......@@ -4,11 +4,13 @@
import Directory
import FilePath
import IO
import IOExts
import List
import System
import HTML.Base ( urlencoded2string )
import SimpleWebService ( runServiceAsCGI )
--------------------------------------------------------------------------------
......@@ -91,6 +93,7 @@ executeWithPAKCS urlparam inputprog = do
shFile = "./PAKCSCALL.sh"
currDir <- getCurrentDirectory
createDirectoryIfMissing True execDir
copyStandardLibs execDir
setCurrentDirectory execDir
writeFile filename prog
writeFile shFile
......@@ -102,7 +105,7 @@ executeWithPAKCS urlparam inputprog = do
(exit1,out1,err1) <- evalCmd "/bin/sh" [shFile] ""
if exit1 > 0
then do setCurrentDirectory currDir
system $ "/bin/rm -r "++execDir
system $ "/bin/rm -r " ++ execDir
return $ parseResult (exit1,out1,err1)
else do writeFile shFile
("#!/bin/sh\n"++
......@@ -122,6 +125,13 @@ executeWithPAKCS urlparam inputprog = do
addBinPath v = "PATH=" ++ pakcsBin v ++ ":" ++ cpmBin v ++
":$PATH && export PATH && "
--- Copies some standard libraries (e.g., for set functions, default rules)
--- to the given directory.
copyStandardLibs :: String -> IO ()
copyStandardLibs dir = do
c <- system $ "/bin/cp -a " ++ "curry_libs/* " ++ dir
when (c > 0) $ hPutStrLn stderr "Cannot copy standard libraries!"
--- Turns the result of the PAKCS execution into the proper plain text
--- representation.
--- @param result - exit status, stdin content and stderr content
......
To install all current web services on www-ps:
1. Login as "mh@siran"
Login as "mh@lepin"
-------------------
2. > cd home/curry/smap/services && make
> cd home/curry/smap/services && make
3. Login as "pakcs@siran"
Login as "pakcs@lepin"
----------------------
4. > cd public_html/smap/exec
5. > cp -p ~mh/public_html/smap/exec/*.cgi .
> cd public_html/smap/exec
> cp -p ~mh/public_html/smap/exec/*.cgi .
> rm -rf curry_libs && cp -a ~mh/public_html/smap/exec/curry_libs .
......@@ -8,6 +8,8 @@ SMAPDIR=$(HOME)/public_html/smap
CGIDIR=$(SMAPDIR)/exec
# Auxiliary Prolog program for sandbox execution:
SWILOAD=safeload.pl
# Directory containing standard libraries for PAKCS2
STDLIBDIR=curry_libs
.PHONY: install
install: Curry_PAKCS Curry_KiCS2 Haskell_GHC Prolog_SWI
......@@ -15,6 +17,8 @@ install: Curry_PAKCS Curry_KiCS2 Haskell_GHC Prolog_SWI
chmod 755 $(CGIDIR)
$(MAKE) uninstall
mv Curry_PAKCS $(CGIDIR)/PAKCS.cgi
cp -a $(STDLIBDIR) $(CGIDIR)/$(STDLIBDIR)
chmod -R go+rX $(CGIDIR)/$(STDLIBDIR)
mv Curry_KiCS2 $(CGIDIR)/KiCS2.cgi
mv Haskell_GHC $(CGIDIR)/GHC.cgi
mv Prolog_SWI $(CGIDIR)/SWI.cgi
......@@ -25,6 +29,7 @@ install: Curry_PAKCS Curry_KiCS2 Haskell_GHC Prolog_SWI
.PHONY: uninstall
uninstall:
cd $(CGIDIR) && rm -f PAKCS.cgi KiCS2.cgi GHC.cgi SWI.cgi $(SWILOAD)
cd $(CGIDIR) && rm -rf $(STDLIBDIR)
Curry_PAKCS: Curry_PAKCS.curry SimpleWebService.curry
$(CURRYSYSTEM) $(CURRYOPTS) :load Curry_PAKCS.curry :save :quit
......
Smap Web Services
=================
This directory contains the implementation of some web services
to execute programs for various languages (Curry, Haskell, Prolog)
and systems.
used by Smap to execute programs for various languages
(Curry, Haskell, Prolog) and systems.
Each service implemented here runs as a cgi script.
This cgi script is intended to be execute by a POST message
Each service implemented here runs as a CGI script.
This CGI script is intended to be executed by a POST message
having the program to be executed on stdin.
The result of the program execution is returned as plain text
in the following format:
......
------------------------------------------------------------------------------
--- 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 December 2018
------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}
module Control.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 Control.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
<?xml version="1.0" standalone="no"?>
<!DOCTYPE primitives SYSTEM "http://www.informatik.uni-kiel.de/~pakcs/primitives.dtd">
<primitives>
<primitive name="allValues" arity="1">
<library>prim_standard</library>
<entry>prim_allValues[raw]</entry>
</primitive>
<primitive name="someValue" arity="1">
<library>prim_standard</library>
<entry>prim_someValue[raw]</entry>
</primitive>
<primitive name="oneValue" arity="1">
<library>prim_standard</library>
<entry>prim_oneValue[raw]</entry>
</primitive>
<primitive name="findall" arity="1">
<library>prim_standard</library>
<entry>prim_findall[raw]</entry>
</primitive>
<primitive name="findfirst" arity="1">
<library>prim_standard</library>
<entry>prim_findfirst[raw]</entry>
</primitive>
<primitive name="isFail" arity="1">
<library>prim_standard</library>
<entry>prim_isFail[raw]</entry>
</primitive>
<primitive name="try" arity="1">
<library>prim_standard</library>
<entry>prim_try[raw]</entry>
</primitive>
<primitive name="rewriteAll" arity="1">
<library>prim_standard</library>
<entry>prim_rewriteAll[raw]</entry>
</primitive>
<primitive name="rewriteSome" arity="1">
<library>prim_standard</library>
<entry>prim_rewriteSome[raw]</entry>
</primitive>
</primitives>
------------------------------------------------------------------------------
--- This library defines a representation of a search space as
--- a tree and various search strategies on this tree.
--- This module implements **strong encapsulation** as discussed in
--- [the JFLP'04 paper](http://www.informatik.uni-kiel.de/~mh/papers/JFLP04_findall.html).
---
--- @author Michael Hanus, Bjoern Peemoeller, Fabian Reck
--- @version December 2018
------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module Control.SearchTree
( SearchTree (..), someSearchTree, getSearchTree
, isDefined, showSearchTree, searchTreeSize, limitSearchTree
, Strategy
, dfsStrategy, bfsStrategy, idsStrategy, idsStrategyWith, diagStrategy
, allValuesWith
, allValuesDFS, allValuesBFS, allValuesIDS, allValuesIDSwith, allValuesDiag
, ValueSequence, vsToList
, getAllValuesWith, printAllValuesWith, printValuesWith
, someValue, someValueWith
) where
import IO ( hFlush, stdout )
import List ( diagonal )
#ifdef __PAKCS__
import Control.Findall ( allValues )
#endif
import Control.ValueSequence
--- A search tree is a value, a failure, or a choice between two search trees.
data SearchTree a = Value a
| Fail Int
| Or (SearchTree a) (SearchTree a)
--- A search strategy maps a search tree into some sequence of values.
--- Using the abtract type of sequence of values (rather than list of values)
--- enables the use of search strategies for encapsulated search
--- with search trees (strong encapsulation) as well as
--- with set functions (weak encapsulation).
type Strategy a = SearchTree a -> ValueSequence a
--- Returns the search tree for some expression.
getSearchTree :: a -> IO (SearchTree a)
getSearchTree x = return (someSearchTree x)
--- Internal operation to return the search tree for some expression.
--- Note that this operation is not purely declarative since
--- the ordering in the resulting search tree depends on the
--- ordering of the program rules.
---
--- Note that in PAKCS the search tree is just a degenerated tree
--- representing all values of the argument expression
--- and it is computed at once (i.e., not lazily!).
someSearchTree :: a -> SearchTree a
#ifdef __PAKCS__
someSearchTree = list2st . allValues
where list2st [] = Fail 0
list2st [x] = Value x
list2st (x:y:ys) = Or (Value x) (list2st (y:ys))
#else
someSearchTree external
#endif
--- Returns True iff the argument is defined, i.e., has a value.
isDefined :: a -> Bool
isDefined x = hasValue (someSearchTree x)
where hasValue y = case y of Value _ -> True
Fail _ -> False
Or t1 t2 -> hasValue t1 || hasValue t2
--- Shows the search tree as an intended line structure
showSearchTree :: Show a => SearchTree a -> String
showSearchTree st = showsST [] st ""
where
-- `showsST ctxt <SearchTree>`, where `ctxt` is a stack of boolean flags
-- indicating whether we show the last alternative of the respective
-- level to enable drawing aesthetical corners
showsST ctxt (Value a) = indent ctxt . shows a . nl
showsST ctxt (Fail _) = indent ctxt . showChar '!' . nl
showsST ctxt (Or t1 t2) = indent ctxt . showChar '?' . nl
. showsST (False : ctxt) t1
. showsST (True : ctxt) t2
indent [] = id
indent (i:is) = showString (concatMap showIndent $ reverse is)
. showChar (if i then llc else lmc)
. showString (hbar : " ")
where showIndent isLast = (if isLast then ' ' else vbar) : " "
vbar = '\x2502' -- vertical bar
hbar = '\x2500' -- horizontal bar
llc = '\x2514' -- left lower corner
lmc = '\x251c' -- left middle corner
nl = showChar '\n'
shows x = showString (show x)
showChar c = (c:)
showString s = (s++)
-- showSearchTree st = showST 0 st ""
-- where
-- showST _ (Value a) = showString "Value: " . shows a . nl
-- showST _ Fail = showString "Fail" . nl
-- showST i (Or t1 t2) = showString "Or "
-- . showST i' t1 . tab i' . showST i' t2
-- where i' = i + 1
-- tab j = showString $ replicate (3 * j) ' '
--- Returns the size (number of Value/Fail/Or nodes) of the search tree.
searchTreeSize :: SearchTree _ -> (Int, Int, Int)
searchTreeSize (Value _) = (1, 0, 0)
searchTreeSize (Fail _) = (0, 1, 0)
searchTreeSize (Or t1 t2) = let (v1, f1, o1) = searchTreeSize t1
(v2, f2, o2) = searchTreeSize t2
in (v1 + v2, f1 + f2, o1 + o2 + 1)
--- Limit the depth of a search tree. Branches which a depth larger
--- than the first argument are replace by `Fail (-1)`.
limitSearchTree :: Int -> SearchTree a -> SearchTree a
limitSearchTree _ v@(Value _) = v
limitSearchTree _ f@(Fail _) = f
limitSearchTree n (Or t1 t2) =
if n<0 then Fail (-1)
else Or (limitSearchTree (n-1) t1) (limitSearchTree (n-1) t2)
------------------------------------------------------------------------------
-- Definition of various search strategies:
------------------------------------------------------------------------------
--- Depth-first search strategy.
dfsStrategy :: Strategy a
dfsStrategy (Fail d) = failVS d
dfsStrategy (Value x) = addVS x emptyVS
dfsStrategy (Or x y) = dfsStrategy x |++| dfsStrategy y
------------------------------------------------------------------------------
--- Breadth-first search strategy.
bfsStrategy :: Strategy a
bfsStrategy t = allBFS [t]
allBFS :: [SearchTree a] -> ValueSequence a
allBFS [] = emptyVS
allBFS (t:ts) = values (t:ts) |++| allBFS (children (t:ts))
children :: [SearchTree a] -> [SearchTree a]
children [] = []
children (Fail _ : ts) = children ts
children (Value _ : ts) = children ts
children (Or x y : ts) = x:y:children ts
-- Transforms a list of search trees into a value sequence where
-- choices are ignored.
values :: [SearchTree a] -> ValueSequence a
values [] = emptyVS
values (Fail d : ts) = failVS d |++| values ts
values (Value x : ts) = addVS x (values ts)
values (Or _ _ : ts) = values ts
------------------------------------------------------------------------------
--- Iterative-deepening search strategy.
idsStrategy :: Strategy a
idsStrategy t = idsStrategyWith defIDSDepth defIDSInc t
--- The default initial search depth for IDS
defIDSDepth :: Int
defIDSDepth = 100
--- The default increasing function for IDS
defIDSInc :: Int -> Int
defIDSInc = (2*)
--- Parameterized iterative-deepening search strategy.
--- The first argument is the initial depth bound and
--- the second argument is a function to increase the depth in each
--- iteration.
idsStrategyWith :: Int -> (Int -> Int) -> Strategy a
idsStrategyWith initdepth incrdepth st =
iterIDS initdepth (collectInBounds 0 initdepth st)
where
iterIDS _ Nil = emptyVS
iterIDS n (Cons x xs) = addVS x (iterIDS n xs)
iterIDS n (FCons fd xs) = failVS fd |++| iterIDS n xs
iterIDS n Abort = let newdepth = incrdepth n
in iterIDS newdepth (collectInBounds n newdepth st)
-- Collect solutions within some level bounds in a tree.
collectInBounds :: Int -> Int -> SearchTree a -> AbortList a
collectInBounds oldbound newbound st = collectLevel newbound st
where
collectLevel d (Fail fd) = if d <newbound-oldbound then FCons fd Nil else Nil
collectLevel d (Value x) = if d<newbound-oldbound then Cons x Nil else Nil
collectLevel d (Or x y) =
if d>0 then concA (collectLevel (d-1) x) (collectLevel (d-1) y)
else Abort
-- List containing "aborts" are used to implement the iterative
-- depeening strategy:
data AbortList a = Nil | Cons a (AbortList a) | FCons Int (AbortList a) | Abort
-- Concatenation on abort lists where aborts are moved to the right.
concA :: AbortList a -> AbortList a -> AbortList a
concA Abort Abort = Abort
concA Abort Nil = Abort
concA Abort (Cons x xs) = Cons x (concA Abort xs)
concA Abort (FCons d xs) = FCons d (concA Abort xs)
concA Nil ys = ys
concA (Cons x xs) ys = Cons x (concA xs ys)
concA (FCons d xs) ys = FCons d (concA xs ys)
------------------------------------------------------------------------------
-- Diagonalization search according to
-- J. Christiansen, S Fischer: EasyCheck - Test Data for Free (FLOPS 2008)
--- Diagonalization search strategy.
diagStrategy :: Strategy a
diagStrategy st = values (diagonal (levels [st]))