;;; Geography Program:
;;; ------------------

;;; INIT:  Initializes the data base
;;; -----

(define INIT
   (lambda []
      (begin (set *Road-Descriptors* (new-environment))
             (set *Location-Index* (new-environment))
             (set *Highway-Synonyms* (new-environment)))))

;;; DRIVER:  Runs a read-process-print loop.
;;; -------

(define DRIVER
   (lambda []
      (begin (print ps cr)
             (string-out ps "      Geo> ")
             (let [[input (read-structure ps)]]
                 (if (= input 'quit)
                     'ok
                     (begin (string-out ps "      Geo= ")
                            (let [[answer (process-input input)]]
                               (if (string answer)
                                   (string-out ps answer)
                                   (print-structure ps answer)))
                            (driver)))))))

;;; PROCESS-INPUT:  Processes an input structure, assumed to be
;;; --------------  written in the simple data language.

(define PROCESS-INPUT
  (lambda [input]
    (dispatch (pproc input)
      [Road (if (bound (arg 1 input) *Road-Descriptors*)
                "Thanks, already known"
                (begin (rebind (arg 1 input) '[] *Road-Descriptors*)
                       'ok))]
      [Highway (if (bound (arg 2 input) *Highway-Synonyms*)
                   "Thanks, already known"
                   (begin (rebind (arg 2 input)
                                  (arg 1 input)
                                  *Highway-Synonyms*)
                          'ok))]
      [Intersection
         (let [[pn1 (canonical-position-name (arg 1 input))]
               [pn2 (canonical-position-name (arg 2 input))]]
            (begin (store-intersection-info pn1 pn2)
                   (store-intersection-info pn2 pn1)
                   'ok))]
      [Location (begin (rebind (arg 1 input)
                               (canonical-position-name (arg 2 input))
                               *Location-Index*)
                       'ok)]
      [Routes (map prettify (Routes-Descs (arg 1 input) (arg 2 input)))]
      [Route (prettify
               (shortest-route-desc (arg 1 input) (arg 2 input)))]
      [$T (error "Unrecognized input" input)])))

(define ROUTES-DESCS
   (lambda [pn-1 pn-2]
      (map (lambda [route-name]
              (cons (canonical-position-name pn-1) route-name))
           (find-routes-descs (canonical-position-name pn-1)
                              (canonical-position-name pn-2)
                              []))))

(define FIND-ROUTES-DESCS
  (lambda [current-point destination used-names]
    (if (= (road-name destination) (road-name current-point))
        [[destination]]
        (let [[inters (except (binding (road-name current-point) *Road-Descriptors*)
                              current-point
                              used-names)]]
          (mappend (lambda [intersection]
                     (map (lambda [route]
                             (cons (cons (first intersection)
                                         (rest current-point))
                                   route))
                          (find-routes-descs
                              (second intersection)
                              destination
                              (cons (road-name current-point)
                                    used-names))))
                   inters)))))

(define EXCEPT
   (lambda [news this used-names]
      (cond [(null news) []]
            [(or (member (road-name (second (first news))) used-names)
                 (and (same-road-name (second (first news)) this)
                      (= (milepost-name (second (first news)))
                         (milepost-name this))))
             (except (rest news) this used-names)]
            [$T (cons (first news)
                      (except (rest news) this used-names))])))

(define SHORTEST-ROUTE-DESC
   (lambda [pn-1 pn-2]
      (letseq [[routes-descs (routes-descs pn-1 pn-2)]
               [lengths (map route-length routes-descs)]
               [shortest (min . lengths)]
               [position (index shortest lengths)]
               [route-desc (nth position routes-descs)]]
         [shortest route-desc])))

(define ROUTE-LENGTH
  (lambda [route]
    (if (= (length route) 1)
        0
        (+ (distance (milepost-name (second route))
                     (if (same-road-name (first route) (second route))
                         (milepost-name (first route))
                         (position-of-road
                            (first route)
                            (binding (road-name (second route))
                                     *Road-Descriptors*))))
           (route-length (rest route))))))

(define DISTANCE
   (lambda [m-name-1 m-name-2]
      (abs (- \m-name-1 \m-name-2))))

(define POSITION-OF-ROAD
   (lambda [rd tuples]
      (cond [(null tuples) (error "No intersection?" tuples)]
            [(same-road-name rd (second (first tuples)))
             (first (first tuples))]
            [$T (position-of-road rd (rest tuples))])))

;;; ROAD-NAMES  Acceptable road names are either atoms or pairs
;;; ==========  of the form (HIGHWAY <label>), where <label> is
;;;             either a numeral or atom.  Thus interstates are
;;;             usually (HIGHWAY I-280), etc.; the coast road is
;;;             (HIGHWAY 1).

;;; (CANONICAL-ROAD-NAME ROAD-NAME)  Designates the canonical
;;; -------------------------------  road name of the road designated
;;;                                  by ROAD-NAME.

(define CANONICAL-ROAD-NAME
   (lambda [road-name]
      (if (atom road-name)
          road-name
          (inverse-binding (arg 1 road-name) *Highway-Synonyms*))))

(define SAME-ROAD-NAME
   (lambda [pn-1 pn-2]
      (= (road-name pn-1) (road-name pn-2))))

;;; POSITION-NAMES:  Acceptable position names are atoms (for locations
;;; ===============  such as Duartes) and structures of the form
;;;                  (milepost <n> <road-name>).  Position-names are
;;;                  canonically represented internally as two-tuples
;;;                  of milepost-names and road-names.

;;; (MILEPOST-NAME POSITION-NAME)   Designates the milepost-name and
;;; (ROAD-NAME POSITION-NAME)       road-name of the position designated
;;; -----------------------------   by POSITION-NAME.
 
(define MILEPOST-NAME first)
(define ROAD-NAME second)

;;; (CANONICAL-POSITION-NAME POSITION-NAME)  Designates the canonical
;;; ---------------------------------------  version of the position
;;;                                          name designated by 
;;;                                          POSITION-NAME.

(define CANONICAL-POSITION-NAME
   (lambda [p-name]
      (cond [(atom p-name) (binding p-name *Location-Index*)]
            [(= (pproc p-name) 'milepost)
             (rcons (arg 1 p-name)
                    (canonical-road-name (arg 2 p-name)))]
            [$T (error "invalid point" p-name)])))

;;; DATA BASE UTILITIES:
;;; ====================

;;; *ROADS* is the environment that, for each road, contains the
;;; information about each intersection along it (in order).
;;; It is an environment that maps canonical road-names onto
;;; rails of two-element rails, each of which contains a milepost-name
;;; and the name of a position on the intersecting road.

;;; (STORE-INTERSECTION-INFO P-NAME-1 P-NAME-2)  Stores that there is
;;; -------------------------------------------  an intersection at the
;;;                                              positions designated by
;;;                                              the designations of 
;;;                                              P-NAME-1 and P-NAME-2.

(define STORE-INTERSECTION-INFO
   (lambda [pn-1 pn-2]
      (rebind (road-name pn-1)
              (sii-helper (binding (road-name pn-1) *Road-Descriptors*)
                          (milepost-name pn-1)
                          pn-2)
              *Road-Descriptors*)))

(define SII-HELPER
  (lambda [inters m-name p-name]
    (cond [(null inters)
           (rcons (rcons m-name p-name))]
          [(and (= (first (first inters)) m-name)
                (not (same-road-name (second (first inters))
                                     p-name)))
           (cons (first inters)
                 (sii-helper (rest inters) m-name p-name))]
          [(= (first (first inters)) m-name)
           inters]
          [(< \m-name \(first (first inters)))
           (cons (rcons m-name p-name) inters)]
          [$T (cons (first inters)
                    (sii-helper (rest inters) m-name p-name))])))

;;;                   Accessory Procedures:
;;;                   ---------------------

;;; Environment Utilities:
;;; ----------------------

;;; (INVERSE-BINDING B CONTOUR)  Designates the variable, if any,
;;; ---------------------------  in CONTOUR that is bound to B,
;;;                              else "Nothing with this binding".

(define INVERSE-BINDING
  (lambda [b contour]
    (letrec [[helper
                (lambda [vars]
                   (cond [(null vars)
                          (error "nothing with this binding" b)]
                         [(= b (binding (first vars) contour))
                          (first vars)]
                         [$T (helper (rest vars))]))]]
       (helper (contour-variables contour)))))

;;; (BOUND KEY ENV)  True just in case variable KEY is bound in ENV.
;;; ---------------

(define BOUND
   (lambda [key env]
      (not (= (binding key env) "unbound variable"))))


;;; Other Utilities:
;;; ----------------

;;; (MAPPEND FUN ARGLIST)  Like MAP, except the results are all
;;; ---------------------  appended together, rather than just
;;;                        gathered into a sequence.  Assumes that
;;; FUN is a function of one argument that designates a sequence or
;;; rail.


(define MAPPEND
   (lambda [fun arglist]
      (append . (map fun arglist))))

;;; (MIN A1 A2 ... An)  Designates the minimum of the numbers
;;; ------------------  designates by A1 through An.

(define MIN
   (lambda args
      (cond [(null args) (error "too few args" args)]
            [(= (length args) 1) (first args)]
            [$T (let [[x (min . (rest args))]]
                   (if (< x (first args))
                       x
                       (first args)))])))

(define PRETTIFY
   (lambda [route]
      (cons '[milage: ,^(first route)]
            (rcons (cons 'route:
                         (rcons . (map (lambda [p-name]
                                          '(milepost . ,p-name))
                                       (second route))))))))

;;; Testing and Setup Utilities:
;;; ----------------------------

;;; (TEST)  Reads and processes one data language expression.
;;; ------

(define TEST
   (lambda []
      (process-datum (read-structure ps))))



(define SETUP
   (mlambda [call]
      (begin (iterate process-datum (pargs call))
             ''ok)))

(define SEE
   (lambda [env]
      (map (lambda [var] [var (binding var env)])
           (contour-variables env))))

(1270)\f3