Our DNA is the interface mechanism
between the nonphysical soul and
physical body. For this interface to
hold both together, genetics must match
soul profile. A slight mismatch in one
will cause a mutation in the other, but
too much of a mismatch keeps the the
soul from seating in the body. So to
genetically modify or create an entire
race, it is not enough to merely
engineer the genetic code, but to
synchronize its profile and growth with
that of the souls intended to occupy the
bodies.
'("$Id$")
;;; * WHMATCH.LSP
;;; Based on Winston/Horn (MATCH) from "Lisp"
;;;; This software is licensed by Patrick H. Winston and Berthold K. P. Horn
;;;; (licensors) for instructional use with the textbooks ``Lisp,'' by Patrick
;;;; H. Winston and Berthold K. P. Horn, and ``Artificial Intelligence,'' by
;;;; Patrick H. Winston. Your are free to make copies of this software and
;;;; modify it for such instructional use as long as:
;;;; 1. You keep this notice intact.
;;;; 2. You cause any modified files to carry a prominent notice stating
;;;; that you modified the files and the date of your modifications.
;;;; This software is licensed ``AS IS'' without warranty and the licensor
;;;; shall have no liability for any alleged defect or damages.
;;;; ----------------------------------------------------------------------
;;;; Converted April 1997 by Reini URBAN to AutoLisp.
;;;;
http://xarch.tu-graz.ac.at/autocad/lisp/whmatch.lsp;;;; 24/08/98 - fixed all errors by Serge Pashkov (PSW)
;;;;
;;;; Extended match example.
;;;; Supports: ? + * (< x) (? x) (+ x) (> x) (* x) (RESTRICTION ? x)
;;;; Highly recommended to read the book to understand its strength.
;;;; ----------------------------------------------------------------------
;;; (WHMATCH pattern expr) - list matching (=> Winston/Horn "Lisp")
;;; Supports:
;;; ? * + (> x) (? x) (< x) (+ x) (* x) (RESTRICTION ? predicate)
;;; returns NIL if no match, else the actual binding or T
;;; (? x) == (> x)
;;;
;;; Pattern variables:
;;; ? - any symbol
;;; + - any not-empty sequence of symbols (one or more)
;;; * - any sequence of symbols (null or more)
;;;
;;; (pattern-indicator pattern-variable) - bounds a symbol to the found pattern
;;; (> x) - as (? x)
;;; (? x) - bounds x to the matched symbol
;;; (< x) - matches the previous matched x
;;; (+ x) - bounds x to the matched not-empty sequence
;;; (* x) - bounds x to the matched sequence
;;;
;;; (RESTRICTION pattern-indicator predicate)
;;; (RESTRICTION ? predicate) - if the predicate applies to the symbol
;;; (RESTRICTION + predicate) - if the predicate applies to the not-empty sequence
;;; (not yet implemented)
;;; (RESTRICTION * predicate) - if the predicate applies to the sequence
;;; (not yet implemented)
;;;History:
;;; 29/04/97 - Reini Urban, first version
;;; converted from lisp to AutoLISP
;;; this had errors with *, (+ x), (* x) and RESTRICTION
;;; 24/08/98 - fixed all errors by Serge Pashkov (PSW)
;;; no errors anymore
;;; Samples:
;|
(whmatch '(color (? x) (? y))
'(color apple red))
=> ((X apple)(Y red))
(whmatch '((> x) + (< x))
'(color apple red color))
=> ((X color))
(whmatch '((> x) (+ y) (< x))
'(color apple red color))
=> ((X color)(y apple red)
(whmatch '((> x) + (< x))
'(abc is the same as abc))
=> ((X ABC))
(whmatch '((+ x) (RESTRICTION ? numberp) +)
'(abc is the number 1 or not ?))
=> ((X ABC IS THE NUMBER))
(whmatch '((* x) abc +)
'(abc is which ?))
=> T
(whmatch '((* x) 1 (+ y))
'(abc is the number 1 or what is which ?))
=> ((X ABC IS THE NUMBER) (Y OR WHAT IS WHICH ?))
(whmatch '((* x) ? (+ y))
'(abc is which ?))
=> ((Y IS WHICH ?)) ;because ? matches abc not the last question mark
(whmatch '((* x) which (* y))
'(abc is which))
=> (X ABS IS)
(whmatch '((+ x) (RESTRICTION ? numberp) (+ y))
'(abc is the number 1 or not ?))
=> ((X ABC IS THE NUMBER)(Y OR NOT ?))
|;
;;; AutoLISP 'or' workaround. need the value, not just T or nil
;;; Anyway: you can safely replace every 'or' with 'cond' and
;;; enclose the arguments in double brackets as done here in this code
;|
(defun or2 (a b) ;instead of (or a b)
(cond ((a))
((b))))
(defun or3 (a b c) ;instead of (or a b c)
(cond ((a))
((b))
((c))))
|;
;;; helper funcs:
;;; better seperate data-functions from the program code
;;; easier to change the data-structures and pattern-syntax afterwards
(defun add-value (variable value bindings)
(append bindings (list (list variable value))))
(defun find-value (variable bindings)
(cadr (assoc variable bindings)))
;;; X ABC nil => (X ABC)
;;; X IS (X ABC) => (X ABC IS)
(defun add-list (variable datum bindings)
(cond ((null bindings) (list (list variable datum)))
((equal variable (caar bindings))
(cons (cons variable (append (cdar bindings) (list datum)))
(cdr bindings)))
(T (cons (car bindings)
(add-list variable datum (cdr bindings))))))
(defun pattern-ind (p)
(car p))
(defun pattern-var (p)
(cadr p))
;;; special case for + variable, extra function because of the lack of let in AutoLISP
(defun whmatch-+ (p d bindings / new-values)
(setq new-values (add-list (pattern-var (car p))
(car d)
bindings))
(cond ((whmatch-hlp (cdr p) (cdr d) new-values)) ;should be 'or' but AutoLISP is different...
((whmatch-hlp p (cdr d) new-values))))
(defun restriction-ind (pattern-element)
(cadr pattern-element))
(defun restriction-pred (pattern-element)
(cddr pattern-element))
(defun restriction-test (pred args)
(cond ((null pred) t)
((apply (car pred) (list args))
(restriction-test (cdr pred) args))
(T nil)))
;;; workaround for the lack of &optional arguments
;;; called from in-between
(defun whmatch-hlp (p d bindings)
(cond
((and (null p)(null d)) ;success
(cond ((null bindings) T)
(T bindings)))
;;; ((or (null p)(null d)) nil) ;failed
;; PSW 24/08/98. Previous line is wrong for patterns * or (* x)
;; We need to make separate checks.
((or (eq (car p) '?) ;? pattern
(equal (car p)(car d))) ;or same
(whmatch-hlp (cdr p)(cdr d) bindings))
((eq (car p) '+) ;+ pattern, one or more
(cond ((whmatch-hlp (cdr p) (cdr d) bindings)) ;found
((whmatch-hlp p (cdr d) bindings)))) ;or try next
((eq (car p) '*) ;* pattern, null or more
(cond ((whmatch-hlp (cdr p) d bindings)) ;none
((whmatch-hlp (cdr p) (cdr d) bindings)) ;or like +
((whmatch-hlp p (cdr d) bindings))))
((atom (car p)) nil)
((or (eq (pattern-ind (car p)) '>) ;> Var.
(eq (pattern-ind (car p)) '?))
(whmatch-hlp (cdr p) (cdr d)
(add-value (pattern-var (car p))
(car d)
bindings)))
((eq (pattern-ind (car p)) '