#!/usr/lib/gcl-2.6.8/unixport/saved_gcl -f

;; a primitive PDDL parser:

(defmacro define (&rest stuff)
  (cond ((endp stuff)
	 (list 'pddl-syntax-error
	       "empty define ~a~%"
	       (list 'quote (cons 'define stuff))))
	((or (not (listp (first stuff)))
	     (not (= (length (first stuff)) 2)))
	 (list 'pddl-syntax-error
	       "you want to define a WHAT? (~a)~%"
	       (list 'quote (first stuff))))
	(t
	 (list 'pddl-define-thing
	       (list 'quote (first (first stuff)))
	       (list 'quote (second (first stuff)))
	       (list 'quote (rest stuff))))
	))

(setq *pddl-error* nil)
(setq *pddl-warning* nil)
(setq *pddl-defines* nil)

(defun pddl-error (msg &rest args)
  (format t (concatenate 'string "error: " msg) args)
  (setq *pddl-error* t))

(defun pddl-warning (msg &rest args)
  (format t (concatenate 'string "warning: " msg) args)
  (setq *pddl-warning* t))

(defun pddl-define-thing (thing name elements)
  (setq *pddl-defines* (cons (cons (list thing name)
				   elements)
			     *pddl-defines*))
  t)


;; main program:

(cond ((<= (length si::*command-args*) 1)
       (format t "~a: <file>~%" (nth 0 si::*command-args*))
       (quit)))

;; process command line
(setq *write-network-graph* nil)
(setq *check-network-is-a-tree* nil)
(setq *convert-plan* nil)
(setq *print-max* nil)
(setq *write-sets* nil)
(setq *add-init-to-goal* nil)
(setq *count-max* 0)
(setq *max-op* nil)
(setq *debug* nil)
(setq *abstract-to-n* 100)
(setq *abstraction-done* nil)

(do ((rem-arg-list (cdr si::*command-args*) (cdr rem-arg-list)))
    ((endp rem-arg-list) t)
    (let ((arg (car rem-arg-list)))
      (cond ((equal arg "-set")
	     (setq *write-sets* t))
	    ((equal arg "-add")
	     (setq *add-init-to-goal* t))
	    ((equal arg "-g")
	     (setq *write-network-graph* t))
	    ((equal arg "-check")
	     (setq *check-network-is-a-tree* t))
	    ((equal arg "-print-max")
	     (setq *print-max* t))
	    ((equal arg "-debug")
	     (setq *debug* t))
	    ((equal arg "-plan")
	     (setq *convert-plan* t))
	    ((equal arg "-max")
	     (cond ((endp (cdr rem-arg-list))
		    (format t "error: -max without argument~%")
		    (quit)))
	     (let ((n (read-from-string (cadr rem-arg-list))))
	       (cond ((not (numberp n))
		      (format t "error: argument of -max is not a number~%")
		      (quit)))
	       (setq *count-max* n))
	     (setq rem-arg-list (cdr rem-arg-list)))
	    ((equal arg "-abs")
	     (cond ((endp (cdr rem-arg-list))
		    (format t "error: -abs without argument~%")
		    (quit)))
	     (let ((n (read-from-string (cadr rem-arg-list))))
	       (cond ((not (numberp n))
		      (format t "error: argument of -abs is not a number~%")
		      (quit)))
	       (setq *abstract-to-n* n))
	     (setq rem-arg-list (cdr rem-arg-list)))
	    ((equal arg "-bound")
	     (cond ((endp (cdr rem-arg-list))
		    (format t "error: -bound without argument~%")
		    (quit)))
	     (let ((n (read-from-string (cadr rem-arg-list))))
	       (cond ((not (numberp n))
		      (format t "error: argument of -bound is not a number~%")
		      (quit)))
	       (setq *max-op* n))
	     (setq rem-arg-list (cdr rem-arg-list)))
	    (t (load arg)))))

;; if we had a read/parse error, quit
(cond (*pddl-error*
       (quit)))

;; do we have a pipesworld problem definition?
(setq prob (find-if #'(lambda (def)
			(and (eq (caar def) 'problem)
			     (equal (assoc ':domain (cdr def))
				    '(:domain pipesworld_strips))))
		    *pddl-defines*))
(cond ((null prob)
       (format t "no pipesworld problem found in input~%")
       (quit)))

(setq objs (cdr (assoc ':objects (cdr prob))))
(setq init (cdr (assoc ':init (cdr prob))))
(setq goal (cdadr (assoc ':goal (cdr prob))))

(cond (*debug*
       (format t "objects: ~a~%" objs)
       (format t "init: ~a~%" init)
       (format t "goal: ~a~%" goal)
       ))

(defun parse-typed-objects (rem-obj-list objs)
  (cond ((endp rem-obj-list)
	 (cond ((endp objs) nil)
	       (t (list (cons 'object objs)))))
	((eq (car rem-obj-list) '-)
	 (let* ((type-name (cadr rem-obj-list))
		(res (parse-typed-objects (cddr rem-obj-list) nil))
		(type-in-res (assoc type-name res)))
	   (cond (type-in-res
		  (rplacd type-in-res (append objs (cdr type-in-res)))
		  res)
		 (t (cons (cons type-name objs) res))
		 )))
	(t (parse-typed-objects (cdr rem-obj-list)
				(cons (car rem-obj-list) objs)))
	))

(setq typed-objs (parse-typed-objects objs nil))
(cond (*debug*
       (format t "batches: ~a~%" (cdr (assoc 'batch-atom typed-objs)))
       (format t "pipes: ~a~%" (cdr (assoc 'pipe typed-objs)))
       (format t "areas: ~a~%" (cdr (assoc 'area typed-objs)))
       (format t "tanks: ~a~%" (cdr (assoc 'tank-slot typed-objs)))
       ))

(setq *products* '(lco gasoleo rat-a oca1 oc1b))

(setq batch-init
      (mapcar #'(lambda (b)
		  (let ((bpi (find-if #'(lambda (atom)
					  (and (eq (first atom) 'is-product)
					       (eq (second atom) b)))
				      init)))
		    (cond ((null bpi)
			   (format t "error: product type of batch ~a~% not specified" b)
			   (quit))
			  (t (cons b (third bpi)))
			  )))
	      (cdr (assoc 'batch-atom typed-objs))))

(cond (*debug*
       (format t "batches: ~a~%" batch-init)
       ))

(defun find-pipe-init-seq (pipe batch init)
  (cond ((null batch)
	 (let ((first-batch
		(find-if #'(lambda (atom)
			     (and (eq (first atom) 'first)
				  (eq (third atom) pipe)))
			 init)))
	   (cond ((null first-batch)
		  (format t "error: no first batch in pipe ~a~&" pipe)
		  (quit))
		 (t (cons (second first-batch)
			  (find-pipe-init-seq pipe (second first-batch) init)))
		 )))
	((find-if #'(lambda (atom)
		      (and (eq (first atom) 'last)
			   (eq (second atom) batch)
			   (eq (third atom) pipe)))
		  init)
	 nil)
	(t (let ((next-batch
		  (find-if #'(lambda (atom)
			       (and (eq (first atom) 'follow)
				    (eq (third atom) batch)))
			   init)))
	     (cond ((null next-batch)
		    (format t "error: no first batch in pipe ~a~&" pipe)
		    (quit))
		   (t (cons (second next-batch)
			    (find-pipe-init-seq pipe (second next-batch) init)))
		   )))
	))

(setq pipe-init
      (mapcar #'(lambda (pipe)
		  (cons pipe
			(mapcar #'(lambda (b)
				    (cdr (assoc b batch-init)))
				(find-pipe-init-seq pipe nil init))))
	      (cdr (assoc 'pipe typed-objs))))
(cond (*debug*
       (format t "pipes: ~a~%" pipe-init)
       ))

(defun find-batches-in-area (area init)
  (cond ((endp init) nil)
	((and (eq (first (car init)) 'on)
	      (eq (third (car init)) area))
	 (cons (second (car init)) (find-batches-in-area area (cdr init))))
	(t (find-batches-in-area area (cdr init)))))

(setq area-init
      (mapcar #'(lambda (area)
		  (cons area (find-batches-in-area area init)))
	      (cdr (assoc 'area typed-objs))))
(cond (*debug*
       (format t "area init: ~a~%" area-init)
       ))

(setq area-init-count
      (mapcar
       #'(lambda (a)
	   (let ((ic (mapcar #'(lambda (p) (cons p 0)) *products*)))
	     (dolist (b (cdr a) t)
	       (let ((icb (assoc (cdr (assoc b batch-init)) ic)))
		 (rplacd icb (+ (cdr icb) 1))))
	     (cons (car a) ic)))
       area-init))
(cond (*debug*
       (format t "init counts by area: ~a~%" area-init-count)
       ))

(setq space-init
      (let ((sp (mapcar
		 #'(lambda (a)
		     (cons (car a) (mapcar
				    #'(lambda (p) (cons p 0)) *products*)))
		 area-init)))
	(dolist (atom init t)
	  (cond ((eq (car atom) 'tank-slot-product-location)
		 (rplacd (assoc (third atom) (cdr (assoc (fourth atom) sp)))
			 (+ (cdr (assoc (third atom)
					(cdr (assoc (fourth atom) sp))))
			    1)))))
	sp))
(cond (*debug*
       (format t "init space by area: ~a~%" space-init)
       ))

(setq area-goal
      (mapcar #'(lambda (area)
		  (cons area (find-batches-in-area area goal)))
	      (cdr (assoc 'area typed-objs))))
(cond (*debug*
       (format t "goals by area: ~a~%" area-goal)
       ))

(setq area-goal-count
      (mapcar
       #'(lambda (a)
	   (let ((gc (mapcar #'(lambda (p) (cons p 0)) *products*)))
	     (dolist (b (cdr a) t)
	       (let ((gcb (assoc (cdr (assoc b batch-init)) gc)))
		 (rplacd gcb (+ (cdr gcb) 1))))
	     (if *add-init-to-goal*
		 (dolist (gcp gc t)
		   (if (> (cdr gcp) 0)
		       (rplacd gcp
			       (+ (cdr gcp)
				  (cdr (assoc (car gcp)
					(cdr (assoc (car a)
					      area-init-count)))))))))
	     (cons (car a) gc)))
       area-goal))
(cond (*debug*
       (format t "goal counts by area: ~a~%" area-goal-count)
       ))

(setq product-goal-count
      (sort (let ((freq (mapcar #'(lambda (p) (cons p 0)) *products*)))
	      (dolist (a area-goal-count freq)
		(dolist (i (cdr a) t)
		  (if (> (cdr i) 0)
		      (let ((c (assoc (car i) freq)))
			(rplacd c (+ (cdr c) 1))))
		  )))
	    #'> :key #'cdr))
(cond (*debug*
       (format t "products in area goals: ~a~%" product-goal-count)
       ))

(defun apply-abstraction-to-list (l amap)
  (mapcar #'(lambda (p) (cdr (assoc p amap))) l))

(defun apply-abstraction-to-count (cv amap aset)
  (let ((res (mapcar #'(lambda (p) (cons p 0)) aset)))
    (dolist (c cv res)
      (rplacd (assoc (cdr (assoc (car c) amap)) res)
	      (+ (cdr (assoc (cdr (assoc (car c) amap)) res)) (cdr c)))
      )))

(cond ((< *abstract-to-n* (length *products*))
       (let ((amap (mapcar #'(lambda (p) (cons p p)) *products*)))
	 (dolist (pgc (subseq product-goal-count *abstract-to-n*) t)
	   (rplacd (assoc (car pgc) amap)
		   (car (nth (- *abstract-to-n* 1) product-goal-count))))
	 (let ((aset (delete-duplicates (mapcar #'cdr amap))))
	   (dolist (p pipe-init t)
	     (rplacd p (apply-abstraction-to-list (cdr p) amap)))
	   (dolist (a area-init-count t)
	     (rplacd a (apply-abstraction-to-count (cdr a) amap aset)))
	   (dolist (a space-init t)
	     (rplacd a (apply-abstraction-to-count (cdr a) amap aset)))
	   (dolist (a area-goal-count t)
	     (rplacd a (apply-abstraction-to-count (cdr a) amap aset)))
	   (setq *products* aset)
	   (cond (*debug*
		  (format t "abs. product set: ~a~%" *products*)
		  (format t "abs. pipe contents: ~a~%" pipe-init)
		  (format t "abs. init counts: ~a~%" area-init-count)
		  (format t "abs. init space: ~a~%" space-init)
		  (format t "abs. goal counts: ~a~%" area-goal-count)
		  ))
	   ))))

;; extract network graph

(setq nw-edge-list
      (mapcar #'(lambda (p)
		  (let ((p-conn (find-if #'(lambda (atom)
					     (and (eq (first atom) 'connect)
						  (eq (fourth atom) (car p))))
					 init)))
		    (cond ((null p-conn)
			   (format t "error: pipe ~a not connected anywhere~%"
				   (car p))
			   (quit))
			  (t (cdr p-conn)))))
	      pipe-init))

(defun find-adjacent (node edge-list)
  (cond ((endp edge-list) nil)
	((eq (caar edge-list) node)
	 (cons (cadar edge-list) (find-adjacent node (cdr edge-list))))
	((eq (cadar edge-list) node)
	 (cons (caar edge-list) (find-adjacent node (cdr edge-list))))
	(t (find-adjacent node (cdr edge-list)))))

(setq nw-adj-list
      (mapcar #'(lambda (a) (cons (car a) (find-adjacent (car a) nw-edge-list)))
	      area-init))

(defun get-node-list (adj-list) (mapcar #'car adj-list))

(defun find-cycle-dfs (neighbours visited adj-list)
  (cond ((endp neighbours) (values nil visited))
	((find (car neighbours) (cddr visited))
	 (values t (cons (car neighbours) visited)))
	((not (eq (car neighbours) (cadr visited)))
	 (multiple-value-bind
	  (b1-cycle b1-visited)
	  (find-cycle-dfs (cdr (assoc (car neighbours) adj-list))
			  (cons (car neighbours) visited)
			  adj-list)
	  (cond (b1-cycle (values t b1-visited))
		(t (multiple-value-bind
		    (bn-cycle bn-visited)
		    (find-cycle-dfs (cdr neighbours) visited adj-list)
		    (cond (bn-cycle bn-visited)
			  (t (values nil (remove-duplicates
					  (append b1-visited bn-visited))))
			  )))
		)))
	(t (find-cycle-dfs (cdr neighbours) visited adj-list))
	))

(defun find-cycle (rem-nodes adj-list)
  (cond ((endp rem-nodes) nil)
	(t (multiple-value-bind
	    (n1-cycle n1-visited)
	    (find-cycle-dfs (cdr (assoc (car rem-nodes) adj-list))
			    (list (car rem-nodes))
			    adj-list)
	    (cond (n1-cycle n1-visited)
		  (t (find-cycle
		      (remove-if #'(lambda (n) (find n n1-visited)) rem-nodes)
		      adj-list))
		  )))
	))


;; find maximum counter value:

;; - longest pipe length
(dolist (p pipe-init t)
  (if (> (length (cdr p)) *count-max*)
      (setq *count-max* (length (cdr p)))))

;; - largest number of batches of any type
(dolist (p *products* t)
  (let ((n 0))
    (dolist (b batch-init t)
      (if (eq (cdr b) p)
	  (setq n (+ n 1))))
    (if (> n *count-max*)
	(setq *count-max* n))))

;; - largest number of tank spaces of any type in any area,
;; but only if problem is from pw-tankage domain
(if (cdr (assoc 'tank-slot typed-objs))
    (dolist (area-sp space-init t)
      (dolist (prod-sp (cdr area-sp) t)
	(if (> (cdr prod-sp) *count-max*)
	    (setq *count-max* (cdr prod-sp))))))

;; - max-op, but only if we have a bound argument
(if (numberp *max-op*)
    (if (> *max-op* *count-max*)
	(setq *count-max* *max-op*)))

;; alternative output modes:

(cond

 ;; write the network graph in dot format
 (*write-network-graph*
  (format t "graph network {~%")
  (format t " node [shape=circle,width=0.5];~%")
  (format t " edge [style=bold,len=1.5];~%")
  (format t " overlap=false;~%")
  (format t " sep=0.5;~%")
  (format t " splines=false;~%")
  (let ((cyc (find-cycle (get-node-list nw-adj-list) nw-adj-list)))
    (cond (cyc (format t " label=\"network constains a cycle: ~a\";~%" cyc))
	  (t (format t "label=\"network is a tree\";~%"))))
  (dolist (a area-init t)
    (format t " ~a [label=\"~a\"];~%" (car a) (car a)))
  (dolist (e nw-edge-list t)
    (format t " ~a -- ~a [label=\"~a (~a)\"];~%"
	    (first e) (second e) (third e)
	    (length (cdr (assoc (third e) pipe-init)))))
  (format t "}~%")
  (quit))

 ;; print the max counter value
 (*print-max*
  (format t "max = ~a~%" *count-max*)
  (quit))

 ;; check if network is a tree (not really an output mode, but causes
 ;; a quit if it's not)
 (*check-network-is-a-tree*
  (let ((cyc (find-cycle (get-node-list nw-adj-list) nw-adj-list)))
    (cond (cyc
	   (format t "error: network constains a cycle: ~a~%" cyc)
	   (quit))
	  )))

 ;; convert and print input plan
 (*convert-plan*
  ;; do we have a plan to convert?
  (setq plan (find-if #'(lambda (def) (eq (caar def) 'plan)) *pddl-defines*))
  (cond ((null plan)
	 (format t "no plan found in input~%")
	 (quit)))
  (dolist (action (cdr plan) t)
    (cond ((eq (first action) 'push-start)
	   (format t "(push-start ~a ~a ~a ~a ? ? ~a)~%"
		   (second action) (fourth action) (fifth action)
		   (seventh action) (eighth action))
	   (do ((n 1 (+ n 1)))
	       ((< n (length (cdr (assoc (second action) pipe-init)))) t)
	       (format t "(push-continue ~a C~a C~a ? ?)~%"
		       (second action) n (+ n 1))))
	  ((eq (first action) 'push-end)
	   (format t "(push-end ~a ~a ~a ~a ? ? ?)~%"
		   (second action)
		   (length (cdr (assoc (second action) pipe-init)))
		   (third action) (fourth action)))
	  ((eq (first action) 'pop-start)
	   (format t "(pop-start ~a ~a ~a ~a ~a ? ? ~a)~%"
		   (second action)
		   (length (cdr (assoc (second action) pipe-init)))
		   (fourth action) (fifth action)
		   (seventh action) (eighth action))
	   (do ((n (length (cdr (assoc (second action) pipe-init))) (- n 1)))
	       ((> n 1) t)
	       (format t "(pop-continue ~a C~a C~a ? ?)~%"
		       (second action) n (- n 1))))
	  ((eq (first action) 'pop-end)
	   (format t "(pop-end ~a ~a ~a ? ? ?)~%"
		   (second action) (third action) (fourth action)))
	  (t (format t "error: unrecognised action ~a in plan~%" action)
	     (quit))
	  ))
  (quit))

 ) ;; end of cond

;; print converted problem:

(format t "(define (problem ~a)~%" (cadar prob))
(if (cdr (assoc 'tank-slot typed-objs))
    (format t "(:domain pipesworld-tankage-ae)~%~%")
  (format t "(:domain pipesworld-notankage-ae)~%~%"))

;; objects:
(format t "(:objects~%")
;; - pipes
(dolist (p pipe-init t) (format t "~a " (car p)))
(format t "- pipe~%")
;; - areas
(dolist (ai area-init t) (format t "~a " (car ai)))
(format t "- area~%")
;; - numbers
(do ((n 2 (+ n 1)))
    ((> n *count-max*) t)
    (format t "C~a " n))
(format t " - count)~%~%")

;; init:
(format t "(:init~%")

;; - inc
(do ((n 0 (+ n 1)))
    ((>= n *count-max*) t)
    (format t "(inc C~a C~a)~%" n (+ n 1)))

;; - may-interface
(dolist (atom init t)
  (if (eq (first atom) 'may-interface)
      (format t "~a~%" atom)))

;; - pipes
(dolist (p pipe-init t)
  (format t "~a~%" (find-if #'(lambda (atom)
				(and (eq (first atom) 'connect)
				     (eq (fourth atom) (car p))))
			    init))
  (format t "(length ~a C~a)~%" (car p) (length (cdr p)))
  (do ((bs (cdr p) (cdr bs))
       (pos 1 (+ pos 1)))
      ((endp bs) t)
      (format t "(contents ~a C~a ~a)~%" (car p) pos (car bs)))
  (format t "(normal ~a)~%" (car p))
  ;; op bound, if given
  (cond ((numberp *max-op*)
	 (format t "(max-op ~a C~a)~%" (car p) *max-op*)))
  )

;; - areas
(dolist (a area-init-count t)
  (dolist (p *products* t)
    (format t "(number-on ~a ~a C~a)~%" p (car a) (cdr (assoc p (cdr a))))
    ;; if we have a pw-tankage problem, we also need to set
    ;; initial free space
    (if (cdr (assoc 'tank-slot typed-objs))
	(let ((tot-sp (cdr (assoc p (cdr (assoc (car a) space-init))))))
	  (cond ((< tot-sp (cdr (assoc p (cdr a))))
		 (format t "error: not enough tank space for ~a at ~a~%"
			 p (car a))
		 (quit)))
	  (format t "(free-space ~a ~a C~a)~%" p (car a)
		  (- tot-sp (cdr (assoc p (cdr a)))))))
    ))
(format t ")~%~%")

;; goal:
(format t "(:goal (and~%")
(dolist (a area-goal-count t)
  (dolist (p *products* t)
    (if (> (cdr (assoc p (cdr a))) 0)
	(format t "(number-on ~a ~a C~a)~%"
		p (car a) (cdr (assoc p (cdr a)))))
    ))

(dolist (p pipe-init t)
  (format t "(normal ~a)~%" (car p)))

(format t "))~%~%")

;; end problem definition
(format t ")~%")
