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

;;;		  LastEditDate = Wed Nov 27 15:49:51 1985  - Mark Boggs

;;; ----------------------------------------------------------------
;;;
;;; 		(c) Copyright, 1982,
;;; 			by Mark Boggs & Steven Romig
;;; 			All rights reserved
;;;
;;; ----------------------------------------------------------------

;;; This file contains low-level utility functions for the various
;;; parsing packages (DYPAR, CASPAR, & MULTIPAR).  There are admittedly
;;; some functions in this file that are in need of improvement, and
;;; many should be commented.

;;; HISTORY
; 5-Dic-00 Nuria Ripoll Lerin, Universidad de Zaragoza, Spain
; 	Modifico eval$ para q vayan las reglas de transformacion.
;
; 9-May-00 Jose Angel Banares Universidad de Zaragoza, Spain
;   Corrijo eval$ para que se ligen variables. Requiere comprobacion exhaustiva.
; 14-Jun-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Fixed bug in dy-insert by adding member test on entry.
;
; 17-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Converted msg to format.
;	Added package support and noted file dependencies.
;
; 14-Jan-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Made changes for conversion to GCL3.1 common lisp.
;	memq -> memb
;	last -> mlast
;	putprop -> ptprop
;	#+ usage eliminated and all Franz dependent calls removed
;
; 24-Aug-84  Scott A. Safier (ss) at Carnegie-Mellon University
;	made changes for conversion to common lisp.  boundp =>
;	is-boundp; used #+ syntax for other changes
;
; 07-Aug-82  Mark Boggs (wmb) at Carnegie-Mellon University
;	Added non-reader related functions from seminit.l
;
; 03-Aug-82  Mark Boggs (wmb) at Carnegie-Mellon University
;	Added new functions for McDypar package.
;
; 14-Dec-81  Mark Boggs (wmb) at Carnegie-Mellon University
;	Added condense and changed union.  Deleted Garbage.
;	Moved others to macros.l
;
; 30-Jun-81  Mark Boggs (wmb) at Carnegie-Mellon University
;	Added functions defined by Steven Romig for his version of
;	the parsing system.
;
; 22-Apr-81  Mark Boggs (wmb) at Carnegie-Mellon University
;	Extensively updated.
;
; 02-Mar-81  Mark Boggs (wmb) at Carnegie-Mellon University
;	Created.  These functions are intended to define those functions
;	not found in Franz Lisp, but used in the UCI lisp source code.
;	SEMMORE created "Mon Mar  2 08:51:40 1981"

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

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

(proclaim '(special $outport$))

(defun FOO () nil)
(defun BAR () t)

;;; condense removes duplication/redundancy from a list


(putd 'quick-condense (getd 'remove-duplicates))
;(defun quick-condense (lst)
;    (do ((l lst (cdr l))
;	 (ans))
;	((null l) ans)
;	(cond ((null (memb (car l) (cdr l)))
;	       (setcons (car l) ans)))))

;;; removes duplicate atoms from a list destructively.

(putd 'nodup (getd 'delete-duplicates))

;;; assumes args are lists of atoms. Returns first elt of intersection, NIL
;;; if none.


(defun intersectp (lst1 lst2)
    (and lst2
	 (do ((l lst1 (cdr l)))
	     ((null l) nil)
	     (and (memb (car l) lst2)
		  (return (car l))))))

;;; converts string or list to atom


(defun explode (sym)
  (mapcar #'(lambda (ch)
	      (intern (make-string 1 :initial-element ch)))
	  (concatenate 'list (symbol-name sym))))

(putd 'explodec (getd 'explode))


(defun at (str-l)
    (etypecase str-l
	(string (intern str-l))
	(list (intern (concatenate 'string
			  (mapcan #'(lambda (at-ch)
					    (etypecase at-ch
						(character (list at-ch))
						(symbol (concatenate 'list
							    (symbol-name
								at-ch)))
						(number (concatenate 'list
							    (princ-to-string
								at-ch)))))
				  str-l))))))
(putd 'atcat (getd 'concat))

(defun flatten (s)
    (cond ((null s) nil)
	  ((atom s) (list s))
	  (t (append (flatten (car s))
		     (flatten (cdr s))))))

(defun setsym (str count)
    (ptprop str count ':current))

(defun initsym (str)
    (ptprop str 0 ':current))

(defun newsym (str)
    (let ((count (or (get str :current) 0)))
	 (ptprop str (1+ count) :current)
	 (concat str (1+ count))))

(defun prompt (x)
    (princ (code-char x) *standard-input*) 
    (princ (code-char 32) *standard-input*))
	
(defun spaces (n)
    (do ((n n (1- n)))
	((zerop n) nil)
	(princ (code-char 32))))

(defun filter (x outs)
    (mapcan (funl (w)
		  (cond ((not (memb w outs))
			 (list w))
			(t nil)))
	    x))

(defun match-for-key (lst lst2)
    (mapc
	(funl (e)
	      (member e lst2))
	lst))

(defun cap-sentence (sen)
    (let* ((tmp (explode (car sen)))
	   (cha (getcharn (car tmp) 1)))
	  (cond ((and (< 97 cha)
		      (> 122 cha))
		 (setq tmp (cons (code-char (- cha 32)) (cdr tmp)))
		 (cons (implode tmp) (cdr sen)))
		(t sen))))

;;; What follows is from Steve Romig's file nice.l 6-30-81

(defun lowercase-list (lst)
    (mapcar
	(funl (token)
	      (lowercase-word token))
	lst))

(defun lowercase-word (token)
    (implode
	(mapcar
	    (funl (letter)
		  (setq letter (getcharn letter 1))
		  (cond ((and (> letter 64)
			      (< letter 91))
			 (setq letter (+ letter 32))))
		  (code-char letter))
	    (explode token))))

(defun memcap (x lst)
    (memb (lowercase-word x) lst))

(defun pause (where &optional reason val)
    (format t "Pause from ~S~&" where)
    (and reason
	 (format t "Reason: ~S~&" reason))
    (and val (eval val))
    (format t "~&Type CONTINUE to return with nil, ~
	         RESUME to return with the value given.~&")
    (format t "~&Pause : ")

    (prog (elt)
loopstart
	  (setq elt (read))
	  (cond ((member elt '(C Continue c continue))
		 (format t "~&Continuing...~&")
		 (return nil))
		((member elt '(R RESUME r resume))
		 (format t "~&Pause Return Value : ")
		 (setq elt (eval (read)))
		 (format t "~&Resuming with ~S~&" elt)
		 (return elt))
		((member elt '(? H h HELP help))
		 (format t "~&Type CONTINUE to return with nil, ~
			      RESUME to return with the value given.~&")
		 (format t "~&Pause : "))
		(t (format t "~S~&Pause : " (eval elt))))
	  (go loopstart)))

;;; What follows was formerly the file xmore.l
;;; New functions to make the new pattern matcher work in Franz
;;; Created on or about Thu Jul 30 00:16:16 1981 --wmb

;;; prelist returns the first n elements of a list

(defun prelist (lis n)
    (cond ((> (abs n) (length lis)) lis)
	  ((plusp n)
	   (ldiff lis (Cnth lis (1+ n))))
	  ((minusp n)
	   (ldiff lis (Cnth lis (- (length lis) n))))))

;;; subset returns the subset of some list that returns a non-nil value when
;;; fn is applied to them.

(defun subset (fn lis)
    (do ((l lis (cdr l))
	 (result))
	((null l) result)
	(cond ((funcall fn (car l))
	       (setcons (car l) result)))))
	

;;; this is true if all the elements of l return a non-nil value when fn is
;;; applied to them, otherwise nil.

(defun uci-every (fn l)
    (do ((l l (cdr l)))
	((null l) t)
	(cond ((null (apply fn (list (car l))))
	       (return nil)))))


;;; Prettyprints property list of atom FN

(defun ppl (fn)
    (princ fn)(terpri)
    (do ((p (plist fn) (cddr p)))
	((null p) fn)
	(format t "~S	~S~&" (car p) (cadr p))))

; ----------------------------------------------------------------
;like eval, but returns NIL for UBA's and quotes strings.

; (get exp 'value)
; The (boundp exp) was inserted in place of the commented code, because
; that code was returning a val of nil for the expressions it was fed.
; Another case of UCI incompatability.

;;;(defun eval$ (exp)
;;;    (prog (binding)
;;;          (return
;;;             (cond ((or (consp exp) (numberp exp))
;;;		    (eval exp))
;;;                   ((stringp exp) exp)
;;;;                   ((or (not (setq binding (boundp exp))) ; a change here. CODIGO ORIGINAL 
;;;		   ((or (not (setq binding (when (boundp exp) (eval exp)))) ; Modificado JangelB 3/5/00.
;;;			(and (litatom (cdr binding))
;;;			     (null (cdr binding)))); a change here
;;;		    nil)
;;;		   (t (cdr binding))))))

(defun eval$ (exp)
    (prog (binding)
          (return
             (cond ((or (consp exp) (numberp exp))
		    (eval exp))
                   ((stringp exp) 
		    exp)
;                   ((or (not (setq binding (boundp exp))) ; a change here. CODIGO ORIGINAL 
		   ((or (not (setq binding (when (boundp exp) (eval exp)))) ; Modificado JangelB 3/5/00.
			(and (litatom  binding)
			     (null  binding))); a change here
		    nil)
		   ((and binding (litatom (cdr  binding))
			 (not (null (cdr  binding))))
					; a change here
;; Nuria Ripoll. Modifico lo q devuelve...no se muy bien pq...
		    ;;(setf (symbol-value exp) (car binding)))
			(setf (symbol-value exp) binding))
					 ; no se como habria que considerar este caso, si la variable tiene varios valores.
					; Por ahora devuelvo el primero
;; Nuria Ripoll. Modifico lo q devuelve para corregir las reglas de transformación.
		    ;;(t  (setf (symbol-value exp) (car binding)))))))
  		   (t  (setf (symbol-value exp) binding))))))


(defun litonly (lstatm)
    (and (consp lstatm)
	 (null (cdr lstatm))
	 (litatom (car lstatm))
	 (not (get-rule-hash (car lstatm)))
         (not (get (car lstatm) ':function))
         (not (member (car (explode (car lstatm))) '(< $ &)))))


(defun setdiff (l1 l2)
    (do ((lis l1 (cdr lis))
	 (result))
	((null lis) result)
	(cond ((null (member (car lis) l2 :test #'equal))
	       (setq result (cons (car lis) result))))))

;;; faster version of setdiff using eql
(defun set-diff (lis1 lis2)
    (do ((target lis1 (cdr target))
	 (ans))
	((null target) ans)
	(cond ((not (member (car target) lis2 :test #'eql)
		    )
	       (setq ans (cons (car target) ans))))))


;;;     *** LOW LEVEL DESTRUCTIVEL LIST SORTING MANIPULATION FUNCTIONS ***


;;; dy-mergelists
;;;
;;; returns a sorted list containing the elements of the two
;;; argument lists.  The code may not be pretty but it goes like a bat.
;;; the lists passed to dy-mergelists should be sorted before they get here.

(defun dy-mergelists  (ls1 ls2)
  (prog (result current)
	(setq current (setq result (cons nil nil)))
loop	(cond ((null ls1)
	       (rplacd current ls2)
	       (return (cdr result)))
	      ((null ls2)
	       (rplacd current ls1)
	       (return (cdr result)))
	      ((eql (car ls1) (car ls2))
	       (setq ls1 (cdr ls1)))
	      ((string-lessp (car ls1) (car ls2))
	       (rplacd current ls1)
	       (setq current ls1
		     ls1 (cdr ls1)))
	      (t (rplacd current ls2)
		 (setq current ls2
		       ls2 (cdr ls2))))
	(go loop)))

;;; to insure we don't do something silly to both lists we will copy the
;;; first list before we pass it to dy-mergelists.  This might go away when
;;; I mod dy-mergelist to insure that it doesn't trash the first list.

(defun dy-merge (lst1 lst2)
    (dy-mergelists (copy-list lst1) lst2))

;;; dy-insert does a binary search to find the place to put element x
;;; into list l.

(defun dy-insert (x l)
    (cond ((null x) l)
	  ((member x l) l)
	  ((null l) (list x))
	  (t 
	      (prog (l1 n n1 y)
		    (setq l1 l)
		    (setq n (length l))
	       a    (setq n1 (/ (1+ n) 2))
	            (setf n1 (floor n1))
	            (setq y (Cnth l1 n1))
		    (cond ((< n 3)
			   (cond ((string-lessp x (car y))
				  (rplacd y (cons (car y) (cdr y)))
				  (rplaca y x))
				 ((eql n 1) (rplacd y (cons x (cdr y))))
				 ((string-lessp x (cadr y))
				  (rplacd (cdr y)
					  (cons (cadr y) (cddr y)))
				  (rplaca (cdr y) x))
				 (t (rplacd (cdr y) (cons x (cddr y))))))
			  ((string-lessp x (car y))
			   (setq n (1- n1))
			   (go a))
			  (t (setq l1 (cdr y)
				   n (- n n1))
			     (go a))))
	      l)))

(defun nd-dy-insert (x lst)
    (dy-insert x (copy-list lst)))

(defun dy-sort (lst)
    (dy-merge1 lst (length lst)))

(defun dy-merge1 (lst nitems)
    (prog (tmp tmp2)
	  (cond ((greaterp nitems 7)	        ; split and merge
		 (setq tmp (splitlist lst (setq tmp2 (quotient nitems 2))))
		 (return (dy-mergelists
			     (dy-merge1 (car tmp) tmp2)
			     (dy-merge1 (cdr tmp) tmp2))))
		(t (do ((l lst (cdr l))		; bubble sort
			(fin))
		       ((null l))
		       (do ((ll lst (cdr ll)))
			   ((eql fin (cdr ll)) (setq fin ll))
			   (cond ((not (string-lessp (car ll) (cadr ll)))
				  (rplaca ll (prog1 (cadr ll)
						    (rplaca (cdr ll)
							    (car ll))))))))
		   (return lst)))))

(defvar *general1-loaded1  t)