Added GNU Common LISP mdlscp handler
This commit is contained in:
simon
parent
ba41b051d8
commit
ac5b7d07f7
316
handlers/mdlscp
Executable file
316
handlers/mdlscp
Executable file
|
|
@ -0,0 +1,316 @@
|
|||
#!/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
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in a new issue