317 lines
8.9 KiB
Plaintext
Executable file
317 lines
8.9 KiB
Plaintext
Executable file
#!/usr/bin/gcl -f
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; ;;
|
|
;; mdlscpd.lsp ;;
|
|
;; ;;
|
|
;; Purpose: a GILD handler for Multi-Dimensional Locations System ;;
|
|
;; Concept Protocol ;;
|
|
;; ;;
|
|
;; Author: Simon Brooke ;;
|
|
;; Created: November 16 1997 ;;
|
|
;; Copyright: (c) 1997 Simon Brooke. Distributed without any ;;
|
|
;; waranties whatever; free for any use at your own ;;
|
|
;; risk ;;
|
|
;; ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; $Header$
|
|
|
|
|
|
;; concept is represented as (token children definitions), where children is
|
|
;; (concept...) and definitions is ((language-token word ...)...)
|
|
|
|
(make-package "Multidimensional Location System Concept Protocol"
|
|
:nicknames '("mdlscp"))
|
|
(in-package "mdlscp")
|
|
|
|
|
|
(setq *server-name* "CL-MDLSCPD/0.1")
|
|
|
|
(setq *standard-responses*
|
|
'(
|
|
(200 " Query Satisfied")
|
|
(201 " Limit was reached before Depth")
|
|
(202 " Depth could not be reached")
|
|
(210 " Preferred natural language not available")
|
|
(211 " Preferred language not available, limit reached before depth")
|
|
(212 " Preferred language not available, depth could not be reached")
|
|
(400 " Concept unknown")
|
|
(401 " Service refused: private")
|
|
(402 " Service refused: too busy")
|
|
(500 " Server error")))
|
|
|
|
|
|
(defun read-line-to-list (&optional stream)
|
|
"Read a line from stream and return the result as a list of tokens"
|
|
(let
|
|
((input
|
|
(substitute ;; OK, this is a *horrible* fudge
|
|
#\@ #\: ; The standard reader can't cope
|
|
(read-line stream)))) ; with colons, and I need it to.
|
|
; It would be better to use a
|
|
; special read-table...
|
|
(cond
|
|
((> (length input) 0)
|
|
(with-input-from-string (s input)
|
|
(do ((l nil (append l (list token)))
|
|
(token (read s) (read s)))
|
|
((null (listen s)) (append l (list token)))))))))
|
|
|
|
(defun r-e-p (&optional stream)
|
|
"Read a protocol query from stream and print the result there"
|
|
(let ((lines
|
|
(do ((lines nil (cons line lines))
|
|
(line (read-line-to-list stream)(read-line-to-list stream)))
|
|
((null line) lines))))
|
|
(cond (lines
|
|
(let
|
|
((action (cdr (assoc 'action@ lines)))
|
|
(concept (cadr (assoc 'concept@ lines)))
|
|
(iread (cdr (assoc 'i_read@ lines)))
|
|
(depth (cadr (assoc 'depth@ lines)))
|
|
(limit (cadr (assoc 'limit@ lines))))
|
|
(handle-query *lattice* action concept
|
|
iread depth limit stream))))))
|
|
|
|
(defun handle-query (lattice &optional action concept iread depth limit stream)
|
|
"Run an MDLSCP query against lattice and return the result"
|
|
(cond
|
|
((eq action 'define)
|
|
(handle-define lattice concept iread))
|
|
; it's a define query
|
|
((or
|
|
(null concept) ; query seeks default concept
|
|
(eq concept (car lattice))) ; query seeks top of lattice
|
|
(respond lattice iread depth limit stream))
|
|
; just respond
|
|
(t ; otherwise
|
|
(handle-query
|
|
(search-concept-lattice ; find the right place in the lattice
|
|
lattice ; and try again
|
|
concept)
|
|
'query concept iread (or depth 4) (or limit 1024) stream))))
|
|
|
|
|
|
(defun respond (lattice iread depth limit &optional stream)
|
|
"Format this lattice segment into an appropriate mdls response and print it"
|
|
(let*
|
|
((lat
|
|
(prepare-output ; reorder the data for output
|
|
lattice iread depth))
|
|
(d (lattice-depth lattice)) ; check the depth of what we got
|
|
(n (lattice-nodes lattice)) ; and the number of nodes..
|
|
(r (cond ; set the response code
|
|
((null lat) 400) ; didn't find anything
|
|
((> depth d) 202) ; didn't get the requested depth
|
|
((> n limit) 201) ; got more than the requested nodes
|
|
(t 200)))) ; got just what was asked for
|
|
(princ "MDLSCP/1.0 " stream)
|
|
(princ *server-name* stream) ; print identifier
|
|
(terpri stream)
|
|
(princ r stream) ; print the result code
|
|
(princ (cadr (assoc r *standard-responses*)) stream)
|
|
(terpri stream) ; and a human-readable interpretation
|
|
(cond (lat (princ lat)) stream) ; print the result
|
|
(terpri stream)
|
|
r)) ; and return the result code
|
|
|
|
(defun lattice-enumerate (lattice fn)
|
|
"abstract function used internally by lattice-nodes and lattice-depth"
|
|
(cond
|
|
((null (concept-children lattice)) 0)
|
|
(t
|
|
(1+
|
|
(apply fn
|
|
(mapcar
|
|
#'(lambda (child) (lattice-enumerate child fn))
|
|
(concept-children lattice)))))))
|
|
|
|
(defun lattice-nodes (lattice)
|
|
"Return the number of nodes in this lattice as an integer"
|
|
(lattice-enumerate lattice (symbol-function '+)))
|
|
|
|
(defun lattice-depth (lattice)
|
|
"Return the maximum depth of this lattice as an integer"
|
|
(lattice-enumerate lattice (symbol-function 'max)))
|
|
|
|
(defun prepare-output (lattice iread depth)
|
|
"Format this lattice segment into an mdlscp response"
|
|
(cond
|
|
((null lattice) nil)
|
|
(t
|
|
(let
|
|
((token
|
|
(concept-token lattice))
|
|
(description
|
|
(best-description
|
|
(concept-definitions lattice)
|
|
iread))
|
|
(children
|
|
(mapcar
|
|
#'(lambda (child)
|
|
(prepare-output child iread (1- depth)))
|
|
(concept-children lattice))))
|
|
(cond
|
|
((and children (> depth 1))
|
|
(list token description children))
|
|
(t (list token description)))))))
|
|
|
|
|
|
(defun best-description (descriptions languages)
|
|
"Find the best of these descriptions given this set of languages"
|
|
(cond
|
|
((null languages)
|
|
(car descriptions)) ; can't find a good one so use default
|
|
((assoc
|
|
(car languages)
|
|
descriptions)) ; that's fine...
|
|
(t ; otherwise checkout the next best
|
|
(best-description ; language.
|
|
descriptions (cdr languages)))))
|
|
|
|
(defun search-concept-lattice (lattice concept)
|
|
"Search this lattice for this concept, breadth first"
|
|
(do ((to-search (list lattice)
|
|
(cdr
|
|
(append to-search
|
|
(concept-children (car to-search))))))
|
|
((or (null to-search)
|
|
(eq (concept-token (car to-search)) concept))
|
|
(cond (to-search (car to-search))))))
|
|
|
|
(defmacro concept-token (concept)
|
|
(list 'car concept))
|
|
|
|
(defmacro concept-children (concept)
|
|
(list 'cadr concept))
|
|
|
|
(defmacro concept-definitions (concept)
|
|
(list 'caddr concept))
|
|
|
|
(defmacro concept-addchild (concept child)
|
|
(list 'push child (list 'concept-children concept)))
|
|
|
|
(defun addconcept (lattice below new-concept)
|
|
"Non-destructively add new-concept as a child of below in this lattice"
|
|
(cond ((null lattice) nil)
|
|
((eq (concept-token lattice) below)
|
|
(list (concept-token lattice)
|
|
(cons new-concept (concept-children lattice))
|
|
(concept-definitions lattice)))
|
|
(t
|
|
(list
|
|
(concept-token lattice)
|
|
(mapcar #'(lambda
|
|
(child)
|
|
(addconcept child below new-concept))
|
|
(concept-children lattice))
|
|
(concept-definitions lattice)))))
|
|
|
|
|
|
|
|
(setq *lattice* ; for test purposes
|
|
'(everything
|
|
(
|
|
)
|
|
((english abstract top level concept)
|
|
(french tout le monde et ces choses))
|
|
)
|
|
)
|
|
|
|
(setq *lattice*
|
|
(addconcept *lattice* 'everything
|
|
'(event ()
|
|
((english occurence located in time)))))
|
|
|
|
(setq *lattice*
|
|
(addconcept *lattice* 'event
|
|
'(public-event ()
|
|
((english an event to which members of the public
|
|
are invited)))))
|
|
|
|
(setq *lattice*
|
|
(addconcept *lattice* 'event
|
|
'(private-event ()
|
|
((english an event to which only specified people
|
|
are invited)))))
|
|
|
|
(setq *lattice*
|
|
(addconcept *lattice* 'public-event
|
|
'(public-entertainment ()
|
|
((english an event in which performers seek to amuse
|
|
an audience)))))
|
|
|
|
|
|
(setq *lattice*
|
|
(addconcept *lattice* 'public-event
|
|
'(public-meeting ()
|
|
((english an event at which members of the public
|
|
discuss some matter of common interest)))))
|
|
|
|
(setq *lattice*
|
|
(addconcept *lattice* 'public-entertainment
|
|
'(musical-entertainment ()
|
|
((english an entertainment at which perfomers
|
|
play music)))))
|
|
|
|
|
|
(setq *lattice*
|
|
(addconcept *lattice* 'musical-entertainment
|
|
'(concert
|
|
()
|
|
((english a musical entertainment at which the
|
|
audience listens)
|
|
(french une xxx musical que les gens ecoute)
|
|
))))
|
|
|
|
|
|
(setq *lattice*
|
|
(addconcept *lattice* 'musical-entertainment
|
|
'(dance
|
|
(
|
|
(ceilidh
|
|
()
|
|
((english a scottish form of dance at which the
|
|
distinction between audience and performers
|
|
may be blurred))
|
|
)
|
|
)
|
|
((english a musical entertainment at which the
|
|
audience dances))
|
|
)))
|
|
|
|
|
|
(setq *lattice*
|
|
(addconcept *lattice* 'public-entertainment
|
|
'(literary-entertainment
|
|
(
|
|
(play
|
|
(
|
|
(opera
|
|
()
|
|
((english a formal dramatic performance in which
|
|
the words are sung))
|
|
)
|
|
(musical
|
|
()
|
|
((english a dramatic performance interspersed
|
|
with songs))
|
|
)
|
|
)
|
|
((english a live dramatic performance))
|
|
)
|
|
(poetry-reading
|
|
()
|
|
((english an event at which poetry is read))
|
|
)
|
|
)
|
|
((english an entertainment based on speach))
|
|
)))
|
|
|
|
|
|
(r-e-p) ; one shot
|
|
|
|
|
|
|