;;; -*- Mode:Lisp; Package:DYPAR; Base:10; -*-

;;;		  LastEditDate =  11:07:02  Fri, 19-May-89  -- Mark Boggs
;;;---------------------------------------------------------------------
;;;
;;;		Copyright (c) 1982
;;;			by Mark Boggs
;;;			all rights reserved
;;;
;;;---------------------------------------------------------------------

;;; EXTEND.LSP

;;; HISTORY
; 18-Dic-00 Nuria Ripoll.
; 	Creacion de nuevo operador $nombre.
;
; 8-Nov-00 Nuria Ripoll & Moises Gil.
;	Definimos la variable !!ALLPUNCT, que se supone tendria que estar
;	definida en "sxreadl.lsp" pero este fichero no existe.
;
; 22-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Added function application and variable passing to mapinto calls
;	that do not have subpatterns.
;
; 16-Apr-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Added macro def-op to ease the grammar writers burden
;		when defining extension operators.
;	Converted some of the defined extension operators to use def-op.
;
; 27-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Converted from msg to format.
;	Converted from property list patterns to structure based patterns.
;
; 14-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Converted to GCL3.1
;	memq -> memb
;	putprop -> ptprop
;	#+ usage eliminated and all Franz dependent calls removed
;
; 03-May-84  Mark Boggs (wmb) at Carnegie-Mellon University
;	Changed !non-term to a parameter of mapinto as opposed to a
;	special variable.  New name is non-term.
;
; 29-Feb-84  Mark Boggs (wmb) at Carnegie-Mellon University
;	Added handling for (&i value) form and for naming of *var*
;	generated variables.  Revised comments.  Changed behaviour of
;	mapassoc so that a list is always returned.
;
; 04-Dec-81  Mark Boggs (wmb) at Carnegie-Mellon University
;	Created. Function mapinto for variable coercion.
;

(in-package "DYPAR"); :use '("LISP" "USER" "GCLISP"))

(eval-when (compile)
    (if (not (boundp '*macros-loaded*)) (load "macros")))


(proclaim '(special !len !!punct !!allpunct !!non-pattern-operators
		    !!default-assignments))

(defvar !!non-pattern-operators nil)
(defvar !!punct '(%cr %lf %qmark %emark %period %comma %colon %semicolon))

;;------------------------ nuria-moisés -------------------------
;;; Lo definimos nosotros pq el fichero sxreadl.l no esxiste!!
(defvar !!allpunct '(%dash %slash %apost %hash %lparen %rparen %star %bquote %rsbrack %lsbrack
 %bslash %vbar %dquote %lcbrack %rcbrack %labrack %rabrack %amper %percent %dollar %plus %equal 
 %underbar %upcaret %atsign %tilde %cr %lf %qmark %emark %period %comma %colon %semicolon))
;;---------------------------------------------------------------

;;; !!allpunct is defined in sxreadl.l
;;; !len is set in xmatch6.lsp

;;; def-op defines dypar extension operators.  All we do is pass most
;;; of the arguments directly to defun.  The rest are used to set
;;; up cross-reference/function access for dypar.
(defmacro def-op (name xref other-names &rest body)
  `(progn
     (defun ,name ,@body)
     (setcons ',name !!non-pattern-operators)
     (setf (get ',name :symbol) ',xref)
     (setf (get ',name :function) ',name)
     (dolist (nm ',other-names ',name)
       (setf (get nm :symbol) ',xref)
       (setf (get nm :function) ',name))))


;;; MAPINTO is an extension function for the DYPAR-I pattern matcher.
;;; It serves the purpose of mapping a set of possible variable values into
;;; a single value to be returned when any of the possibilities match.
;;; When the pattern matcher is called with a pattern of the form:
;;;		(:= !var (&i value pattern))
;;; a successful match of `pattern' will result in `!var' being associated
;;; with `value'.  `value' can be an atom or a list.  If `value' is a list
;;; mapinto will check to see if the car of that list is `&apply' or `%f'
;;; If this is the case, a function-name is expected as the next element of
;;; value, followed by some number of variables to apply that function to.

;;; Variable correspondences.
;;; input -> remaining unparsed input passed to mapinto
;;; mapval -> value to return if match is successful
;;; pattern -> pattern to match against
;;; position -> position in input string when mapinto is called
;;; match-value -> result of call to pattern matcher with position and pattern
;;;		   as arguments

;;; mapinto returns a list of the form:
;;;	((n t (mapval) (other bindings)))
;;; where n is the new position in the input string, t is an atom telling
;;; the variable assignment clause of the pattern matcher that something
;;; special is going on, mapval is the value to be bound to a variable, and
;;; other bindings are any variable bindings that were caused in the call
;;; to smatch.  If smatch fires more than once, there will be more than one
;;; valid match returned from mapinto.

;;; Other Dypar functions used:  smatch funl mapassoc noassoc consp
;;; Called from:  smatch1
;;; Arguments:  input calling-form
;;; Local Variables: pattern invoker mapval match-value position inv fun
;;;		     arguments v
;;; Global Variables:  !len
;;; Calling form:  (mapinto l_input (&i s_value-to-return l_pattern-to-match))
;;; Returns:  ( [(n_pos t ([a_mapval]) [l_other-bindings] )] )

(defun mapinto (input calling-form cb internal optflg non-term recurse-depth)
  (dlet (((invoker mapval . pattern) calling-form) ; pattern gets what's left
	 (position (list (- !len (length input))))
	 (match-value))
    (declare (ignore invoker))
    (cond

      ;; if the pattern doesn't exist return the value.  A list for
      ;; mapval is meaningless here. *** possible extension point ***
      ((null pattern)
       (if (and (consp mapval)
		(member (car mapval) '(%f &apply &funcall)))
	   (let ((arguments (if (consp (car (cddr mapval)))
				(car (cddr mapval))
				(cddr mapval))))
	     (list2 (car position)
		    t
		    (manyfy
		      (apply (cadr mapval)
			     (if (member (car mapval) '(&funcall %f))
				 (mapassoc2 arguments (cdr cb))
				 (mapassoc arguments (cdr cb)))))))
	   (list2 (car position) t (list mapval))))

      ;; otherwise see if the pattern matches the input.
      ((setq match-value
	     (smatch (list position) pattern internal optflg non-term
		     (1+ recurse-depth)))

       ;; remember that smatch returns a list of its results, and
       ;; that more than one valid match is possible.  So we must map
       ;; our result across the set of match values returned.
       (mapcar
	 (funl (m)
	   (cond

	     ;; the simplest case is (&i value pattern)
	     ((atom mapval)
	      (cond

		;; this is for naming *var* generated vars
		((memb mapval '(*var* !newvars))
		 (nconc
		   (list (car m)
			 t
			 (mapassoc '(*var*) (cdr m)))
		   (noassoc '(*var*) (cdr m))))

		;; the normal case (no *var* stuff)
		(t (nconc (list (car m) t (list mapval))
			  (cdr m)))))

	     ;; the mapvalue was a list with the function
	     ;; invocation symbol as its car. %f is here for
	     ;; backward compatibility.
	     ((memb (car mapval) '(%f &apply &funcall))

	      ;; break apart the mapval into its components
	      (dlet (((inv fun . arguments) mapval))

		;; the grammar writer can explicitly list
		;; the argument variables or not.  We need
		;; only one level of listing.
		(and (consp (car arguments))
		     (setq arguments (car arguments)))

		;; build a value to return including the
		;; results of the function call.
		(nconc
		  (list (car m)
			t

			;; if the function returns a
			;; value it must be passed
			;; in the form of a list.
			(let ((v (apply fun
					(or
					  (and
					    (memb inv
						  '(&funcall %f))
					    (mapassoc2
					      arguments
					      (cdr m)))
					  (mapassoc
					    arguments
					    (cdr m))))))
			  (cond ((atom v) (list v))
				(t v))))
		  (noassoc arguments (cdr m)))))

	     ;; mapvalue was a list but not a function call.
	     (t (nconc (list (car m) t mapval)
		       (cdr m)))))
	 match-value)))))

;;; MAPASSOC does an assoc for each element in `el-list' which must be a list
;;; and returns a list of the results.  It recognizes the occurance of the
;;; DYPAR symbols `*var*' and `!newvars' and treats them specially.
;;; Each Variable value will be returned as a list.
(defun mapassoc (el-list assoc-pairs)
    (mapcar
	(funl (e)
	      (cond ((memb e '(*var* !newvars))
		     (mapassoc (newvars assoc-pairs) assoc-pairs))
		    (t (cdr (assoc e assoc-pairs)))))
	el-list))

(defun mapassoc2 (el-list assoc-pairs)
  (mapcar
    (funl (e)
      (cond ((memb e '(*var* !newvars))
	     (mapassoc (newvars assoc-pairs) assoc-pairs))
	    (t (let ((tmp (cdr (assoc e assoc-pairs))))
		 (or (and (cdr tmp) tmp)
		     (car tmp))))))
    el-list))

;;; NOASSOC reaps the elements in el-list from the assoc list it is passed
;;; as an argument, returning the modified alist.  It is also smart about
;;; `*var*' and `!newvars'
(defun noassoc (el-list assoc-pairs)
  (do ((pairs assoc-pairs (cdr pairs))
       (new (cond ((or (memb '*var* el-list)
		       (memb '!newvars el-list))
		   (newvars assoc-pairs))
		  (t nil)))
       (ans))
      ((null pairs) ans)
    (cond ((not (member (caar pairs) (append new el-list)))
	   (setq ans (nconc (list (car pairs)) ans))))))

;;; RQUOT does floating point division on integers.
(defun rquot (x y)
  (list (quotient (float x) (float y))))

;;; The next set of routines are the basic set of extension
;;; functions used by DYPAR and referenced in the manual.
;;; They also serve as a model for any user defined niladic
;;; extension functions.

;;; $w is used in patterns to match non-numeric non-punctuation
;;; inputs.  !!allpunct is a list of all the punctuation chars.
(def-op $w $ ($word) (inp)
  (and (litatom (car inp))
       (not (memb (car inp) !!allpunct))))

;(defun $w (l)
;  (and (litatom (car l))
;       (not (memb (car l) !!allpunct))))
;(defprop $w $ :symbol)
;(defprop $w $w :function)
;(defprop $word $w :function)

;;; $n checks for numeric inputs.
(def-op $n $n ($number $numb) (inp)
  (numberp (car inp)))

;(defun $n (l)
;  (numberp (car l)))
;(defprop $n $n :symbol)
;(defprop $n $n :function)
;(defprop $number $n :function)
;(defprop $numb $n :function)


;;; $p checks for punctuation.
(def-op $p $ ($p $punc $punctuation) (inp)
  (member (car inp) !!allpunct))

;(defun $p (l)
;  (memb (car l) !!allpunct))
;(defprop $p $ :symbol)
;(defprop $p $p :function)
;(defprop $punctuation $p :function)
;(defprop $punct $p :function)

;;; These next routines are to make the system a little more transparent to
;;; lisp code.
(def-op $lisp-function $ () (inp)
  (symbol-function (car inp)))

;(defun $lisp-function (l)
;  (getd (car l)))
;(defprop $lisp-function $lisp-function :function)
;(defprop $lisp-function $ :symbol)

(def-op $lisp-variable $ () (inp)
  (boundp (car inp)))

;(defun $lisp-variable (l)
;  (or (eql (car l) '%emark)
;      (boundp (car l))))
;(defprop $lisp-variable $lisp-variable :function)
;(defprop $lisp-variable $ :symbol)

;;; For Dictionary lookups.
(def-op $dictionary $ ($d $dict) (inp)
  (get-terminal-hash (car inp)))

;(defun $dictionary (l)
;  (ck-word (car l)))
;(defprop $dictionary $dictionary :function)
;(defprop $dictionary $ :symbol)
;(defprop $d $dictionary :function)

;;; &range is an example of an operator which takes arguments.
;;; We need to make sure that the grammar loading and x-ref rountines
;;; do not alter or use those arguments.
(def-op &range $n (&r) (input pattern cb &rest useless)
  (declare (ignore useless))
  (if (and (numberp (car input))
	   (>= (car input) (if (consp (cadr pattern))
			 (caratom (apply (cadr (cadr pattern)) nil))
			 (cadr pattern)))
	   (<= (car input) (if (consp (caddr pattern))
			 (caratom (apply (cadr (caddr pattern)) nil))
			 (caddr pattern))))
      (list (cons (1+ (car cb)) (cdr cb)))))
;(defprop &range $n :symbol)
;(defprop &range &range :function)


;;; Each of the user defined functions also needs to be identified for DYPAR
;;; by having a value associated with its function property.  We have defined
;;; a number of synonyms for doing thte same thing and all of the synonyms
;;; should also have synonym: properties as mentioned above.
;;; Someday this task should be easier.

(defprop &i mapinto :function)


;;; 18-Dic-00 Nuria Ripoll
(def-op $nombre $ () (l)
	(gethash (car l) *tabla-nombres*))