#!/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