(*
* This file is a component of PropPlan - a model-based planner
* Copyright (C) 2000-2007 Michael Paul Fourman
* homepages.inf.ed.ac.uk/mfourman/tools/propplan
* sourceforge.net/projects/propplan
* michael.fourman (AT) gmail.com
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of version 3 of the GNU Affero General Public License
* as published by the Free Software Foundation.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received the file COPYING, a copy of the GNU Affero
* Public License, along with this program.
* If not, see .
* $Id: PLANNER.ML,v 1.1 2007/12/30 15:31:25 michaelfourman Exp $
*)
nonfix ++ -- before ;
infix AND OR INTERSECTS IMPLIES;
(*
* This file is a component of PropPlan - a model-based planner
* Copyright (C) 2000-2007 Michael Paul Fourman
* homepages.inf.ed.ac.uk/mfourman/tools/propplan
* sourceforge.net/projects/propplan
* michael.fourman (AT) gmail.com
*
* This program is free software: you can redistribute it and/or modify
* it under the terms of version 3 of the GNU Affero General Public License
* as published by the Free Software Foundation.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Affero General Public License for more details.
*
* You should have received the file COPYING, a copy of the GNU Affero
* Public License, along with this program.
* If not, see .
* $Id: PLANNER.ML,v 1.1 2007/12/30 15:31:25 michaelfourman Exp $
*)
functor PLANNER(structure PlanTypes : PLANTYPESSIG
) : PLANNERSIG =
struct
val plannerVersion = "$Id: "
structure Bdd = PlanTypes
open PlanTypes;
fun ss f = SIZE f
fun s() = TOTALSIZE ()
fun length [] = 0 | length (_ :: t) = 1 + length t
fun message s = () (*TextIO.print s;*)
fun retry (Action{ precond, changes, effect, condChanges ,conditions,...})
now_states (* now /\ prev --- find possible previous states before a *)
prev_states =
let val image = PROD changes (++effect) now_states
val FF = FALSE()
fun allowChanges [] image = image
| allowChanges ((a,ch) :: chs) image =
allowChanges chs (++image OR PROD ch (++a) image)
in
if image = FF
then (--prev_states; FF)
else
PROD conditions (allowChanges condChanges image) (++precond AND prev_states)
end;
fun mkPlan timeout (CompiledProblem {init, goals, acts, name, stateVars, constraint, ...}) =
let
val FF = FALSE()
fun nstates f = Int.toString (Bdd.STATES (++f AND EXISTS stateVars (noVars())))
fun try (a as Action{ precond, changes, effect, condChanges ,conditions,name,...})
states = (* find possible next states after a *)
let val enabled = PROD changes (++precond) states
fun allowChanges [] enab = enab
| allowChanges ((a,ch) :: chs) enab =
allowChanges chs (++enab OR PROD ch (++a) enab)
in
REDUCE (PROD conditions (allowChanges condChanges enabled) (++effect))
(++constraint) (* Here we take advantage of the constraint to reduce intermediate BDDs *)
end
fun trace fringe done [] aa next = (--fringe; (aa, REDUCE (next AND ++constraint)(NOT done)))
(* Here we ensure that the constraint is satisfied *)
| trace fringe done (a:: rest) aa next =
let val via_a = try a (++fringe)
in
if ++via_a IMPLIES ++done then
(--via_a; trace fringe done rest aa next)
else
trace fringe (++done) rest (a :: aa) (REDUCE(next OR via_a)
(++constraint AND NOT done))
(* Here we use the constraint to reduce intermediate BDDs *)
end
fun retrace now prev [] = raise Error "Bad path cannot retrace!!"
| retrace now prev (a:: rest) =
let val via_a = retry a (++ now) (++prev)
in
if via_a = FF then
retrace now prev rest
else
(--now;--prev;(a,via_a))
end
fun plan aa goal [] = (--goal; aa)
| plan aa goal ((acts, current) :: history) =
let val (a,via_a) = retrace (goal) (++current) acts
in plan
(a :: aa)
(via_a)
history
end
fun tryGoals achrem [] fringe before = ( -- fringe ; achrem)
| tryGoals (ach, rem) ((g as (goalName,goal)) :: gs) fringe before =
if ++ goal INTERSECTS ++ fringe then
let
val done = goal AND ++ fringe
in
tryGoals ((goalName,(*#usr (Timer.checkCPUTimer timer)*) 0, plan [] done before):: ach, rem)
gs fringe before
end
else
tryGoals(ach,g :: rem) gs fringe before
fun build steps (ach, rem) fringe (now, before) =
let val (ach',rem') = tryGoals ([],[]) rem (++fringe) before
in if rem' <> []
then
let val (aa, next) = trace (++fringe) (++ now) acts [] FF
in
if ++next IMPLIES ++now
then
(message ("\nFor some goals there is no solution.\n"
^ concat (map #1 rem')
^"\n Reachable states exhausted after "
^ PolyML.makestring steps ^ " steps.");
ach)
else
if timeout() then ach
else
(REORDER();
message ("\nStep "
^ PolyML.makestring steps
^ " BDD sizes: now " ^ Int.toString(ss now)
^ ", next " ^ Int.toString(ss next)
^ ", total " ^ Int.toString(s ()));
build
(steps + 1)
(ach @ ach',rem')
next
(now OR ++next, (aa, fringe) :: before)
)
end
else
(REORDER();message( "\nStep "
^ StringCvt.padLeft #" " 3 (" " ^ Int.toString steps)
^ " BDD size: total " ^ StringCvt.padLeft #" " 5
(Int.toString (s ()))
^ "\n All goals achieved" );
(*VO();*)
ach' @ ach)
end
fun space s = s ^ " "
in
message( "\n PropPlan Planner" ^ plannerVersion
^"\n Domain: " ^ name
^"\n Actions: " ^ Int.toString (length acts)
^"\n Variables: " ^ Int.toString (nVars())
^"\n Problems: " ^ concat(map (space o #1) goals));
REORDERING DEFAULT_REORDERING;
(build 0 ([],goals) (++init) (++init,[]))
end
end