;; -*- Mode: Lisp; -*-

;;;; Test problem for CPS -- Navigating the Boston Subway
;;;; File name: subways.lsp
;;;;  modified: Thursday, January 10, 2008 at 10:32:47 by Ken Forbus

;;; Copyright (c) 1986-1991, Kenneth D. Forbus, Northwestern University,
;;; and Johan de Kleer, the Xerox Corporation.
;;; All rights reserved.

;;; See the file legal.txt for a paragraph stating scope of permission
;;; and disclaimer of warranty.  The above copyright notice and that
;;; paragraph must be included in any separate copy of this file.

;; Problem is to get from stop A to stop B on the subway.

;; States correspond to what station we are at.  The only operator
;; is TAKE-LINE(<start station> <destination> <line>), which is
;; implemented procedurally using datastructures representing the
;; subway map.

;;; The subway map is described in terms of two structs, one for
;;; stations and the other for lines.  We assume, simplistically,
;;; that you can get from one station on a line to any other station
;;; on that line in one TAKE-LINE operation.

(in-package :cl-user)

;;; First, the subway map.

(defvar *stations* nil "List of symbols for station names.")
(defvar *lines* nil    "List of symbols for line names.")

(defstruct (subway-station (:print-function subway-station-print-procedure))
  "Data structure representating a single subway station."
  (name nil)         ;; Name of station.
  (lines nil)        ;; Subways lines it is on.
  (coordinates nil)) ;; For advanced CPS versions which use a distance metric.

(defun subway-station-print-procedure (pr str ignore)
   "Print name of station."
   (declare (ignore ignore))
   (format str "<Station ~A>" (subway-station-name pr)))

(defstruct (subway-line (:print-function subway-line-print-procedure))
  "Data structure representing a subway line."
  (name nil)      ;; Name of the line.
  (stations nil)) ;; List of of names of stations on that line.

(defun subway-line-print-procedure (inst str ignore)
   "Print name of subway line."
   (declare (ignore ignore))
   (format str "<Subway ~A>" (subway-line-name inst)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Maintaining the subway map

;; The macros DEFLINE and DEFSTATION simplify constructing a
;; subway map.  The name of each line and station must be symbols.
;; The value of the symbol becomes the corresponding struct.

(defmacro defline (line-name)
   "Define a subway line."
   `(progn
      (defvar ,line-name) 
      (setq ,line-name (make-subway-line :name ',line-name))
      (push ',line-name *lines*)))

(defmacro defstation (name lines &optional (x 0) (y 0))
   "Define a subway station."
   `(progn 
      (defvar ,name)
      (setq ,name (make-subway-station
                    :name ',name
                    :lines ',lines
                    :coordinates (cons ,x ,y)))
      ,@ (mapcar #'(lambda (line)
                     `(push ',name (subway-line-stations ,line))) lines)
      (push ',name *stations*)))

(defun clear-subway-map ()
   "Erase subway map, and all its lines and stations, from memory."
   ;; Good ecology requires removing pointers to the structs.
   (dolist (station *stations*) (makunbound station))
   (dolist (line *lines*) (makunbound line))
  (setq *stations* nil *lines* nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Subway problems

(defclass subway-problem (problem)
  ((destination :initarg :destination :reader destination
               :documentation "Goal state for the problem.")))

(defun setup-subway-problem (destination)
   "set up subway problem.  goal state is name of destination."
  (make-instance 'subway-problem
    :name destination
    :destination destination
    :operators '(take-line))) 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Procedures for CPS interface

(defmethod goal-found? ((state symbol) (problem subway-problem))
  (states-identical? state (destination problem) problem))

(defmethod apply-operator ((operator t) (state symbol) (problem subway-problem))
  "Given current station, return lines that station is on."
  (let ((sprouts nil))
  ;;; Look up the lines that the station is on, and return
  ;;; the list of stations on that line.
    (dolist (line (subway-station-lines (symbol-value state))
                  sprouts)
      (dolist (station (remove state
                               (subway-line-stations (symbol-value line))))
        (push (cons `(take-line ,state ,line ,station) station)
              sprouts))))) 

(defmethod states-identical? ((state1 t) (state2 t) (problem subway-problem))
  (eq state1 state2))

(defmethod solution-element->string ((state symbol)
                                     (operator-instance list)
                                     (problem subway-problem))
  "Print a single leg of the subway trip."
  (format nil "Take the ~A to ~A." (caddr operator-instance) state))

(defmethod state->string ((state symbol) (problem subway-problem))
  (format nil "~A" state))

(defmethod path-filter ((path path) (problem subway-problem))
  "True if same path using same subway line twice in a row."
  ; Flushes paths which use the same subway line twice.   
  ; Such solutions are scenic but silly.
   (eq (third (cadr (so-far path)))
       (third (cadr (cddr (so-far path))))))

;;;; For CPS variants that use distance estimates.

(defmethod distance-remaining ((state symbol)
                               (problem subway-problem))
  "Return the Euclidean distance between the current states of two paths."
  ;;; Uses Euclidean distance between grid coordinates
  (labels ((sqr (x) (* x x)))
    (let ((coords1 (subway-station-coordinates (symbol-value state)))
          (coords2 (subway-station-coordinates (symbol-value (destination problem)))))
      (sqrt (+ (sqr (- (car coords1) (car coords2)))
               (sqr (- (cdr coords1) (cdr coords2))))))))