(defvar *shiporientation* 45)
(defvar *targetangle* 180)

(defmacro defclassic (class supers &rest slots)
  `(defclass
             ,class
             ,supers
             ,(mapcar
               #'(lambda (s); s = slot specification
                   (flet ((build (sn); sn = slot name
                            (list sn ':accessor sn ':initarg
                                  (read-from-string
                                   (concatenate 'string ":" (symbol-name sn))))))
                     (cond ((atom s) (append (build s) '(:initform nil)))
                           ((null (cddr s)) (append (build (first s)) (list ':initform (seconds))))
                           ((eql t (second s))
                            (append (build (first s))
                                    (nthcdr 2 s)
                                    (if (not (member :initform (nthcdr 2 s))) '(:initform nil))))
                           (t s))))
               slots)))

(defclassic mydevice () )

(defmethod get-mouse-coordinates ((self mydevice))
  (vector 0 0))

(defclass mine-feature (icon-feature)
  ((direction :accessor direction :initarg :direction))
  (:default-initargs
    :kind 'MINE
    :dmo-id (gentemp "MINE")))

(defclass ship-feature (icon-feature)
  ((direction :accessor direction :initarg :direction))
  (:default-initargs
    :kind 'SHIP
    :dmo-id (gentemp "SHIP")))

(defmethod feat-to-dmo :around ((self mine-feature))
  (let ((the-chunk (call-next-method)))
    the-chunk))

(defmethod feat-to-dmo :around ((self ship-feature))
  (let ((the-chunk (call-next-method)))
    the-chunk))

(defmethod build-features-for ((self mydevice) (vis-mod vision-module))
  (list (make-instance 'ship-feature
                       :x 255
                       :y 300
                       :value *shiporientation*)
        (make-instance 'mine-feature
                       :x 300
                       :y 400
                       :value *targetangle*)))

(defmethod device-handle-keypress ((self mydevice) key)
  (case key
    (#\d (setf *shiporientation* (mod (- *shiporientation* 1) 360)))
    (#\a (setf *shiporientation* (mod (+ *shiporientation* 1) 360)))
    (#\Space (print "Fire!"))))

(defmethod device-update ((self mydevice) time)
  (progn (proc-display)
         (print "refresh screen!")))

(clear-all)

(define-model psf-demo

(sgp :trace-detail high)

(chunk-type aim-and-fire state current target)
(chunk-type (ship (:include visual-object)) direction)
(chunk-type (mine (:include visual-object)) direction)

(add-dm
 (first-goal ISA aim-and-fire state begin))

(p start
  =goal>
    ISA          aim-and-fire
    state        begin
==>
  =goal>
    state        attend-mine
  +visual-location>
    ISA          visual-location
    kind         mine
)

(p attend-mine
  =goal>
    ISA          aim-and-fire
    state        attend-mine
  =visual-location>
    ISA          visual-location
    kind         mine
  ?visual>
    state        free
==>
  +visual>
    ISA          move-attention
    screen-pos   =visual-location
  =goal>
    state        encode-mine
)

(p encode-mine
  =goal>
    ISA          aim-and-fire
    state        encode-mine
  =visual>
    ISA          visual-object
    value        =angle
==>
  =goal>
    target       =angle
    state        find-ship
)

(p find-ship
  =goal>
    ISA          aim-and-fire
    state        find-ship
==>
  =goal>
    state        attend-ship
  +visual-location>
    ISA          visual-location
    kind         ship
)

(p attend-ship
  =goal>
    ISA          aim-and-fire
    state        attend-ship
  =visual-location>
    ISA          visual-location
    kind         ship
  ?visual>
    state        free
==>
  +visual>
    ISA          move-attention
    screen-pos   =visual-location
  =goal>
    state        encode-ship
)

(p encode-ship
  =goal>
    ISA          aim-and-fire
    state        encode-ship
  =visual>
    ISA          visual-object
    value        =orientation
==>
  =goal>
    current      =orientation
    state        check-ship-angle
)

(p move-counter-clockwise
  =goal>
    ISA          aim-and-fire
    state        check-ship-angle
    current      =current
    target       =target
    !eval!       (> =target =current)
  ?manual>
    state        free
==> 
  +manual>
    ISA          press-key
    key          a
  =goal>
    state        encode-ship
)

(p move-clockwise
  =goal>
    ISA          aim-and-fire
    state        check-ship-angle
    current      =current
    target       =target
    !eval!       (< =target =current)
  ?manual>
    state        free
==> 
  +manual>
    ISA          press-key
    key          d
  =goal>
    state        encode-ship
)

(p fire
  =goal>
    ISA          aim-and-fire
    state        check-ship-angle
    current      =current
    target       =target
    !eval!       (equal =target =current)
  ?manual>
    state        free
==> 
  +manual>
    ISA          press-key
    key          space
  -goal>
)
    

(goal-focus first-goal)
)

(install-device (make-instance 'mydevice))