Next: Listing: Pro2Lisp Up: Parsen und Generieren der Previous: signum

Listing: Lisp2Pro

=11 germanTeX

WidthOfaCharacter

;
; Module Lisp2Pro.Lsp:Transforms an expression given in the Lisp-like
;syntax into the Prolog-like syntax.
;
;
; Michael Herfert.
; 2/92: First Version
; 7/92: Fixed problem with ""
;
;
;
; Exported Item:
;
;pro-printexpr-or-clause-in-lisp-syntax[Function]
;
;Prints the argument in a pretty-print format in Prolog-like syntax.
;
(defun inst-tup-t (x)
(and (inst-t x)
(tup-t (second x)) ))
(defun inst-vari-t (x)
(and (inst-t x)
(vari-t (second x)) ))
(defun variable-binding-t (x)
(and (consp x)
(= 3 (length x))
;(vari-t (first x))
(eq '= (second x)) ))
(defconstant the-non-printing-char (code-char 0))
;; The following constants are parameters of the pretty printer.
;; They can be changed here without side effects:
;; Small number == use many lines when printing:
(defconstant max-len-of-a-simple-arg 7)
;; Small number == use many lines when printing:
(defconstant max-args-per-line 3)
(defun internal-error (&rest msgs)
(mapcar #'rf-print msgs)
(error "Internal-Error.") )
; The type pro-expr describes the Prolog-like representation of a RelFun-
; expression.
; The field len describes the space to print the whole expression
; including commas, spaces and parentheses resp. brackets.
; The contents of value depends on the value of type:
; type = atomic(that means constant or variable)
;value: the string-form of the atom.
; type = argument-list
;value: a list of the arguments.
; type = arg-list-tail (e.g. " (vari x)")
;value: a pro-expr, normaly containing a variable
; type = round-application (e.g. f(x, y))
;value: a list.First element:the functor,
;Second element:the argument-list.
; type = sqr-application (e.g. g[a,b])
;value: a list.First element:the functor or nil if it is a tupel.
;Second element:the argument-list.
; type = is (e.g. X is 5)
;value: a list.First element:left side of is
;Second element:right side of is
; type = variable-binding (e.g. (X = 10))
;value: a list.First element:the variable
;Second element:the binding-value
(defstruct pro-expr
type; dom(type) ={round-application, sqr-application,
;argument-list, arg-list-tail, is,
;variable-binding, atomic}
len; dom(len) = integer
value ; dom(value) = STRING u pro-expr.
)
(defun newline-indent (indent)
(rf-terpri)
(dotimes (i indent)
(rf-princ-like-lisp " ") ))
(defun pps (s &optional (indent 0) &key rem)
;; pretty-print-structure useful for debugging.
(if rem (progn (rf-terpri) (rf-princ-like-lisp rem) (rf-terpri)))
(cond ((pro-expr-p s)
(rf-princ-like-lisp "*pro-expr*")
(newline-indent indent)
(rf-princ-like-lisp "Type: ")
(rf-princ-like-lisp (pro-expr-type s))
(newline-indent indent)
(rf-princ-like-lisp "Len:")
(rf-princ-like-lisp (pro-expr-len s))
(newline-indent indent)
(rf-princ-like-lisp "Val:")
(pps (pro-expr-value s) (+ indent 6)) )
((consp s)
(rf-princ-like-lisp "[")
(mapcar #'(lambda (x)
(newline-indent (1+ indent))
(pps x (1+ indent))
)
s)
(newline-indent indent)
(rf-princ-like-lisp "]"))
(t
(rf-princ-like-lisp s) ))
s)
(defun construct-measure-tree (expr must-be-sqr-p &aux pair)
; Returns a value of type pro-expr.
; The parameter must-be-sqr-p signals that all round applications
; have to be transformed to sqr-applications, because the call came
; from inside a sqr argument list.
(cond ((stringp expr)
(make-pro-expr :type 'atomic
:len(flatsize expr)
:value (prin1-to-string expr) ))
((eq 'id expr)
(make-pro-expr :type 'atomic
:len1
:value "_" ))
((atom expr)
(make-pro-expr :type 'atomic
:len(flatc expr)
:value (string-downcase (princ-to-string expr)) ))
((vari-t expr)
; expr = (VARI symbol)
(let ((name-conc-level (pro-get-variable expr)))
(make-pro-expr :type 'atomic
:len (length name-conc-level)
:value name-conc-level )))
((variable-binding-t expr)
; expr = (variable = binding-value)
; If the interpreter is active, then variable is a symbol with
; leading "_"(e.g. _xyz).
; If the emulator is active then, variable is a taged list
; (e.g. (vari x))
(let ((var-as-str
(if (atom (first expr))
(lisp-var-sym-pro-var-sym (first expr))
(pro-get-variable (car expr)) )))
(setq pair (list (make-pro-expr
:type 'atomic
:len (length var-as-str)
:value var-as-str )
(construct-measure-tree (third expr)
must-be-sqr-p ))))
(make-pro-expr
:type 'variable-binding
:len(+ 3; 3 = length(" = ")
(pro-expr-len (first pair))
(pro-expr-len (second pair)) )
:value pair ))
((is-t expr)
; expr = (IS left right)
; impl. INST on the left side
(setq pair (list (construct-measure-tree (second expr)
t );left
(construct-measure-tree (third expr)
must-be-sqr-p ) ));right
(make-pro-expr
:type 'is
:len(+ 4; 4 = length(" is ")
(pro-expr-len (first pair))
(pro-expr-len (second pair)) )
:value pair ))
((and must-be-sqr-p (tup-t expr))
;; expr = (tup arg-1 .. arg-n)
;; inst outside - suppress the tup-constructor
(setq pair (list; constructor & argument-list
nil
(construct-measure-tree-of-arg-list (cdr expr)
t ) ))
(make-pro-expr
:type 'sqr-application
:len (pro-expr-len (second pair))
:value pair ))
(must-be-sqr-p
;; expr = (constructor arg-1 .. arg-n)
;; inst outside - handle inst like any other constructor
(setq pair (list; constructor & argument-list
(construct-measure-tree (first expr) t)
(construct-measure-tree-of-arg-list (cdr expr) t) ))
(make-pro-expr
:type 'sqr-application
:len(+ (pro-expr-len (first pair))
(pro-expr-len (second pair)) )
:value pair ))
;; there was no inst outside:
;; By the following case (inst (vari x)) is printed as X if there
;; was no inst outside.
;; Remove this sexpression and (inst (vari x)) is printed as inst(X).
((inst-vari-t expr)
(construct-measure-tree (second expr) nil) )
((and (inst-t expr) (not (vari-t (second expr))))
;; expr = (INST (constructor arg-1 .. arg-n))
(construct-measure-tree (second expr) t) )
(t
;; expr = (functor arg-1 .. arg-n)
(setq pair (list
(construct-measure-tree (first expr) nil)
(construct-measure-tree-of-arg-list (cdr expr) nil)))
(make-pro-expr
:type 'round-application
:len (+ (pro-expr-len (first pair))
(pro-expr-len (second pair)) )
:value pair ))))
(defun construct-measure-tree-of-arg-list (arg-list must-be-sqr-p)
; Returns a value of type pro-expr.
; The len-field contains the whole length included parentheses (or brackets),
; commas and spaces.
(do* ((arg-list-tail-p nil)
(l arg-list (cdr l))
(arg (car l) (car l))
(tree nil)
(result nil)
(first-arg-p t nil)
(total-length 2); 2 = length("()")
)
((null l) (make-pro-expr :type 'argument-list
:len total-length
:value result ))
(if (eq ' arg)
(progn (if (not first-arg-p)
; bar not at the beginning:
; 1 = length(" "), space before the bar
(setq total-length (1+ total-length)) )
(setq arg-list-tail-p t) )
(progn (setq tree (construct-measure-tree arg must-be-sqr-p))
(if arg-list-tail-p
; last argument was a bar:
(setq tree (make-pro-expr
:type 'arg-list-tail
:len(pro-expr-len tree)
:value tree )) )
(if (not first-arg-p)
;; 2 = length(", ") resp. length(" ")
;; seperator before this arg.
(setq total-length (+ 2 total-length)) )
(setq total-length (+ total-length
(pro-expr-len tree) ))
(setq result (append result (list tree))) ))))
(defun construct-measure-tree-of-head (head)
(if (consp head)
; head = (functor arg-1 arg-2 .. )
(let ((pair (list
; functor & argument-list
(construct-measure-tree (first head) t)
(construct-measure-tree-of-arg-list (cdr head) t) )))
(make-pro-expr
:type 'round-application
:len(+ (pro-expr-len (first pair))
(pro-expr-len (second pair)) )
:value pair ))
; head = ATOM
(construct-measure-tree head nil) ))
(defun construct-measure-tree-of-footed-rule (arg-list)
(let ((r (construct-measure-tree-of-arg-list arg-list nil)))
(setf (pro-expr-len r) (1+ (pro-expr-len r)))
; 1 = length(" \&") - length(",")
r ))
(defun pro-print (expr &optional (x-cursor 1))
; Prints expr in the Prolog-style syntax.
; Starts at x-cursor.
; Returns no value
(if (consp expr)
(case (car expr)
(hn (if (= 2
(length expr))
(pro-print-clause
(construct-measure-tree-of-head (second expr))
nil
'horn-fact )
(pro-print-clause
(construct-measure-tree-of-head (second expr))
(construct-measure-tree-of-arg-list (cddr expr) nil)
'horn-rule )))
(ft (if (= 3
(length expr))
(pro-print-clause
(construct-measure-tree-of-head (second expr))
(construct-measure-tree-of-arg-list (cddr expr) nil)
'footed-fact )
(pro-print-clause
(construct-measure-tree-of-head (second expr))
(construct-measure-tree-of-footed-rule (cddr expr))
'footed-rule )))
(t (pro-print-tree (construct-measure-tree expr nil) x-cursor)) )
(pro-print-tree (construct-measure-tree expr nil) x-cursor) ))
;; All functions named pro-print-... return the position of the
;; cursor after printing the expression.
(defun pro-print-clause (left right type &optional (x-cursor 1))
; dom(type) = {horn-fact, horn-rule, footed-fact, footed-rule}
(let ((middle nil)
(sep-before-last #,)
(same-line-p nil); == left middle are on the same line
(x x-cursor) )
(case type
(horn-fact (setq middle nil))
(horn-rule (setq middle " :- "))
(footed-fact (setq middle " :-& "))
(footed-rule (setq middle " :- ")
(setq sep-before-last " \&") )
(t (internal-error "unknown type in pro-print-clause: " type)))
(setq x (pro-print-tree left x-cursor))
(if middle
(progn
(setq same-line-p (space-enough-p (length middle) x))
(setq x (pro-print-string middle x)) ))
(if right
(if same-line-p
(setq x (pro-print-arg-list right x (+ x-cursor 2)
the-non-printing-char
the-non-printing-char
sep-before-last ))
(setq x (pro-print-arg-list right x x
the-non-printing-char
the-non-printing-char
sep-before-last )
)))
(pro-print-char #. x) ))
(defun pro-print-tree (tree x-cursor)
(case (pro-expr-type tree)
(atomic
(pro-print-atom tree x-cursor) )
((round-application sqr-application)
(pro-print-application tree x-cursor) )
(arg-list-tail
;; the bar was printed by pro-print-arglist-elements.
;; Now print the tail itself:
(pro-print-tree (pro-expr-value tree) x-cursor) )
(is
(pro-print-is tree x-cursor) )
(variable-binding
(pro-print-variable-binding tree x-cursor) )
(t
(internal-error "Unknown tree-type in pro-print-tree"
(pro-expr-type tree) ))))
(defun pro-print-atom (tree x-cursor)
(if (space-enough-p tree x-cursor)
(progn (rf-princ-like-lisp (pro-expr-value tree))
(+ x-cursor
(pro-expr-len tree) ))
(progn (rf-terpri)
(rf-princ-like-lisp (pro-expr-value tree))
(pro-expr-len tree))))
(defun pro-print-application (tree x-cursor)
; type= round-application or sqr-application
; value = (functor arg-list)
(let ((functor(first (pro-expr-value tree)))
(arg-list (second (pro-expr-value tree)))
(xx-cursor)
(xx nil)
(open-char nil)
(close-char nil) )
(case (pro-expr-type tree)
(round-application (setq open-char round-left)
(setq close-char round-right) )
(sqr-application (setq open-char sqr-left)
(setq close-char sqr-right) )
(t (error "in pro-print-application.")) )
(if functor
; it's not a list:
(progn (if (space-enough-p functor x)
; never break a functor
(setq x x-cursor)
(setq x (pro-newline-and-indent 1)) )
(setq xx (pro-print-tree functor x)) )
; it's a list:
(setq xx x) )
(pro-print-arg-list arg-list
xx
(+ x 2)
open-char
close-char
#, )))
(defun pro-print-arg-list (arg-list x-cursor x-cursor-left
open-char close-char sep-before-last )
(let* ((elements (pro-expr-value arg-list))
(arg-list-info (get-arg-list-info elements))
(nr-of-el (first arg-list-info))
(max-len(second arg-list-info))
(simple-args-p (third arg-list-info))
)
(cond ((and (or (= nr-of-el max-args-per-line)
simple-args-p )
(space-enough-p (pro-expr-len arg-list) x-cursor) )
;; functor(arg-1, arg2)
(pro-print-char close-char
(pro-print-arg-list-elements
elements
(pro-print-char open-char x-cursor)
nil; no extra-lines
sep-before-last )))
((or (space-enough-p max-len x-cursor 2); 2 = length(sqr-left",")
(= x-cursor x-cursor-left) )
;; functor(arg-1,
;;arg-2 )
(pro-print-char close-char
(pro-print-arg-list-elements
elements
(pro-print-char open-char x-cursor)
t; print on separated lines
sep-before-last )))
(t
;; functor(
;;arg-1,
;;arg-2)
(pro-print-char open-char x-cursor)
(pro-print-char close-char
(pro-print-arg-list-elements
elements
(pro-newline-and-indent x-cursor-left)
t; print on separated lines
sep-before-last ))))))
(defun pro-print-arg-list-elements (elements x-cursor
extra-lines sep-before-last)
(do* ((rest-elements elements (cdr rest-elements))
(akt-element (first rest-elements) (first rest-elements))
(next-element (second rest-elements) (second rest-elements))
(first-arg-p t nil)
(x x-cursor) )
((null rest-elements)
x )
;; at least one left to print:
(if (and first-arg-p
(eq 'arg-list-tail (pro-expr-type akt-element)) )
;; tail at the front, no space before the bar:
(return (pro-print-tree akt-element
(pro-print-string " " x) )) )
;; no tail at the begin of the arg-list:
(setq x (pro-print-tree akt-element x))
;; the akt. argument has been printed.
;; How many args are left ?
(cond ((null (cdr rest-elements))
;; no args left:
(return x) )
((not (null (cddr rest-elements)))
;; more then one argument left to print:
(setq x (pro-print-char comma x)) )
;; exact one argument left to print:
((eq 'arg-list-tail
(pro-expr-type next-element) )
;; to print: " "tail
(setq x (pro-print-string " " x)) )
;; last element is not of type arg-list-tail:
((stringp sep-before-last)
(setq x (pro-print-string sep-before-last x)) )
(t
(setq x (pro-print-char sep-before-last x)) ))
(if extra-lines
(setq x (pro-newline-and-indent x-cursor))
(setq x (pro-print-char #space x)) )))
(defun pro-print-is (tree x-cursor)
; type = is
; value = (left-side right-side)
(let ((x x-cursor)
(left-side (first (pro-expr-value tree)))
(right-side (second (pro-expr-value tree))) )
(setq x (pro-print-tree left-side x))
(pro-print-tree right-side
(pro-print-string " is "
x
x-cursor ))))
(defun pro-print-variable-binding (tree x-cursor)
; type = variable-binding
; value = (variablebinding-value)
; Assumes that x-cursor = 1.
(let ((variable (first (pro-expr-value tree)))
(binding-value (second (pro-expr-value tree))) )
(pro-print-tree
binding-value
(pro-print-string " = "
(pro-print-tree variable x-cursor)
x-cursor ))) )
(defun pro-print-char (char x-cursor)
(if (char= char the-non-printing-char)
x-cursor
(case char
((#. #, #space)
(rf-princ-like-lisp char)
(1+ x-cursor) )
(t
(if (space-enough-p 1 x-cursor)
(progn (rf-princ-like-lisp char)
(1+ x-cursor) )
(progn (pro-newline-and-indent 1)
(rf-princ-like-lisp char)
2 )))))); 2 = Cursor column
(defun pro-print-string (str x-cursor &optional (x-cursor-left 1))
; Tries to print str on the current line.
; If not possible print on the next line at column x-cursor-left.
(let ((str-wo-blank ""))
(cond ((space-enough-p (length str) x-cursor)
; fits on line
(rf-princ-like-lisp str)
(+ x-cursor
(length str) ))
((space-enough-p (length str) x-cursor-left)
; next line with indentation
(pro-newline-and-indent x-cursor-left)
(if (char= #Space
(char str 0))
(setq str-wo-blank (subseq str 1))
(setq str-wo-blank str) )
(rf-princ-like-lisp str-wo-blank)
(+ x-cursor-left
(length str-wo-blank) ))
(t
; next line without indentation
(pro-newline-and-indent 1)
(if (char= #Space
(char str 0))
(setq str-wo-blank (subseq str 1))
(setq str-wo-blank str) )
(rf-princ-like-lisp str-wo-blank)
(+ x-cursor-left
(length str-wo-blank) )))))
(defun pro-newline-and-indent (x)
(rf-terpri)
(dotimes (i (1- x) x) (rf-princ-like-lisp " ")) )
(defun space-enough-p (tree-or-number x-cursor &optional (extra-space 0))
; Note:the last column is reserved for special characters, which
;never should be printed at the begin of a line (e.g comma,
;point).
(= (- *rf-print-width* x-cursor extra-space)
(if (pro-expr-p tree-or-number)
(pro-expr-len tree-or-number)
tree-or-number )))
(defun pro-get-variable (var)
; var = (VARI name level)
; where the level-field is optional.
; Example: var = (VARI time 127) == "Time:127"
(let ((level (level-of var))
(name (string-upcase
(string-downcase (princ-to-string
(second var)) )
:start 0
:end 1 )))
(if (not (null level))
(setq name (strcat name ":" (princ-to-string level))) )
(if (digit-char-p (character (subseq name 0 1)))
(strcat "_" name)
name )))
(defun lisp-var-sym-pro-var-sym (lisp-var-sym)
; Example:input:_xyz
;output:Xyz
(let ((pro-name
(nstring-upcase (nstring-downcase
(subseq (princ-to-string lisp-var-sym) 1))
:start 0
:end 1 )))
(if (digit-char-p (character (subseq pro-name 0 1)))
(strcat "_" pro-name)
pro-name )))
(defun get-arg-list-info (elements)
;; Returns a list.1.: No. of elements in elements.
;;2.: Length of biggest element.
;;3.: simple-arg-p
(do* ((n 0 (1+ n))
(maxi 0 (max maxi
(pro-expr-len element) ))
(simple-arg-p t (and simple-arg-p
(or (eq 'atomic
(pro-expr-type element) )
(= (pro-expr-len element)
max-len-of-a-simple-arg))))
(l elements (cdr l))
(element (car l) (car l) )
)
((null l)
(list n maxi simple-arg-p) )))
;
;; End of Module Lisp2Pro.Lsp
;


Harold Boley & Michael Herfert (herfert@dfki.uni-kl.de)