Page Numbers: Yes X: 306 Y: 1.0" First Page: 1
Margins: Top: 1.0" Bottom: 1.3"
Heading:

EXAMPLES FOR LECTURE #7 LISP: LANGUAGE AND LITERATURE May 3, 1984
————————————————————————————————————————————

Examples for Lecture #7

Filed as:[phylum]<3-lisp>course>notes>Lecture-07.examples
User.cm:[phylum]<BrianSmith>system>user.classic
Last edited:May 3, 1984 1:03 PM

————————————————————————————————————————————

First: the behaviour generated:

Geo> (Road Alpine)
Geo= ok
...
Geo> (Intersection (milepost 9 PageMill) (milepost 11 Alpine))
Geo= ok
...
Geo> (route Joses Duartes)
Geo= [[mileage: 31]
[route: (milepost 1 ElCamino)
(milepost 0 ElCamino)
(milepost 9 PageMill)
(milepost 19 Alpine)
(milepost 1 Pescadero)]]
Geo> (route Joses SkyLonda)
Geo= [[mileage: 11]
[route: (milepost 1 ElCamino)
(milepost 2 ElCamino)
(milepost 0 Willow)
(milepost 4 SandHill)
(milepost 6 Woodside)
(milepost 15 LaHonda)]]

Second: the program itself (note: this is pretty ugly code, for reasons to be explained in class)

;;; 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))))

Finally, the initial database:

;;; Data Base of Connections and Locations:
;;; ---------------------------------------

(Road AlamedaDeLasPulgas)
(Road Alpine)
(Road ElCamino)
(Road HalfMoonBay)
(Road Highway-1)
(Road Interstate-280)
(Road JuniperoSerra)
(Road LaHonda)
(Road PageMill)
(Road Pescadero)
(Road Portola)
(Road SandHill)
(Road Skyline)
(Road Willow)
(Road Woodside)

(Highway 1 Highway-1)
(Highway 84 LaHonda)
(Highway 92 HalfMoonBay)
(Highway 82 ElCamino)
(Highway 35 SkyLine)
(Highway I-280 Interstate-280)

(Intersection (milepost 0 PageMill) (milepost 0 ElCamino))

(Intersection (milepost 1 PageMill) (milepost 0 JuniperoSerra))
(Intersection (milepost 2 PageMill) (milepost 0 Interstate-280))
(Intersection (milepost 9 PageMill) (milepost 11 Alpine))

(Intersection (milepost 13 Skyline) (milepost 15 LaHonda))
(Intersection (milepost 20 Skyline) (milepost 12 Alpine))

(Intersection (milepost 19 Alpine) (milepost 14 Pescadero))
(Intersection (milepost 20 Alpine) (milepost 8 LaHonda))

(Intersection (milepost 0 Pescadero) (milepost 42 (Highway 1)))

(Intersection (milepost 0 LaHonda) (milepost 47 (Highway 1)))

(Intersection (milepost 0 Alpine) (milepost 3 JuniperoSerra))
(Intersection (milepost 0 Alpine) (milepost 0 AlamedaDeLasPulgas))
(Intersection (milepost 0 Alpine) (milepost 0 SandHill))
(Intersection (milepost 0 Alpine) (milepost 0 Willow))

(Intersection (milepost 1 Alpine) (milepost 2 (Highway I-280)))
(Intersection (milepost 2 SandHill) (milepost 4 (Highway I-280)))

(Intersection (milepost 4 SandHill) (milepost 7 Woodside))
(Intersection (milepost 4 SandHill) (milepost 0 Portola))

(Intersection (milepost 0 Woodside) (milepost 6 ElCamino))
(Intersection (milepost 2 Woodside) (milepost 3 AlamedaDeLasPulgas))
(Intersection (milepost 3 Woodside) (milepost 6 Interstate-280))
(Intersection (milepost 6 Woodside) (milepost 18 LaHonda))

(Intersection (milepost 4 Portola) (milepost 6 Alpine))

(Intersection (milepost 0 (Highway 92)) (milepost 14 Interstate-280))
(Intersection (milepost 2 (Highway 92)) (milepost 0 Skyline))
(Intersection (milepost 7 (Highway 92)) (milepost 57 (Highway 1)))

(Intersection (milepost 2 Willow) (milepost 2 ElCamino))

(Location Joses (milepost 1 ElCamino))
(Location SantaCruz (milepost 0 (Highway 1)))
(Location SanGregorio (milepost 1 LaHonda))
(Location HalfMoonBay (milepost 57 (Highway 1)))
(Location Pescadero (milepost 1 Pescadero))
(Location Duartes (milepost 1 Pescadero))
(Location SkyLonda (milepost 15 (Highway 84)))