Re: pcase defuns

[LdBeth <andpuke@foxmail.com>]

[-- Attachment #1: Type: text/plain, Size: 887 bytes --]


>>>>> In <871r299e5j.fsf@gnu.org> 
>>>>>	Tassilo Horn <tsdh@gnu.org> wrote:
Tassilo> Andrew Hyatt <ahyatt@gmail.com> writes:

Tassilo> Hi Andrew,

> As a part of a personal project, I wrote a way to define functions in
> an equivalent way to pcases.  For example:
>
> (pcase-defun mytest (a b _)
>  "Match on 'a 'b with the third argument a wildcard"
>  "a b match")
>
> (pcase-defun mytest (c ,var _)
>  "Match on 'c binding VAR, with the third argument a wildcard"
>  (format "c %s match" var) )
>
> (mytest 'a 'b 'c) -> "a b match"
> (mytest 'c 100 'c) -> "c 100 match"

Tassilo> So that's basically similar to cl-defgeneric / cl-defmethod just with
Tassilo> pcase pattern matching, right?


That reminds me of an old tiny piece of Common Lisp code from CMU AI
Repository that implements single inheritance message passing OOP,
which could be easily ported to Emacs Lisp.

-- 
LDB



[-- Attachment #2: boops.lisp --]
[-- Type: text/plain, Size: 11385 bytes --]

;;; -*-Mode: Lisp; Syntax: Common-lisp; Package: BOOPS -*-

;;; Copyright (c) 1992,1991,1990,1989,1988 Koenraad De Smedt

;;;   Koenraad De Smedt
;;;   Unit of Experimental and Theoretical Psychology 
;;;   Leiden University
;;;   P.O. Box 9555
;;;   2300 RB  Leiden
;;;   The Netherlands
;;;   E-mail: desmedt@rulfsw.leidenuniv.nl

;;; BOOPS (Beginner's Object Oriented Programming System) is an
;;; applicative object-oriented programming system implemented as an
;;; extension of Common LISP. It is a scaled-down version of ORBIT
;;; (Steels 1983) and CommonORBIT (De Smedt 1987) modified under the
;;; influence of OOPS (Luger & Stubblefield 1989, "AI and the design
;;; of expert systems", Chapter 14).

;;; BOOPS is distributed in the hope that it will be useful, but
;;; without any warranty. No author or distributor accepts
;;; responsibility to anyone for the consequences of using it or for
;;; whether it serves any particular purpose or works at all, unless
;;; he says so in writing.

;;; Copyright Release Statement:

;;; Everyone is granted permission to copy, modify and redistribute
;;; BOOPS but only under the conditions that (1) distribution is free
;;; and without cost, (2) any modifications are also sent to the above
;;; address, and (3) this entire notice is preserved on all copies.

(defpackage "BOOPS"
  (:use "COMMON-LISP")
  (:export
   "A"
   "AN"
   "DEFASPECT"
   "DEFOBJECT"
   "EEN"
   "ISA"
   "ISA?"
   "MESSAGE"
   "OBJECT"
   "SET-VALUE"
   "SHOW"
   "TRACE-MESSAGE"
   "UNDEFINED"
   "UNTRACE-MESSAGE"
   ))

(in-package "BOOPS")

;;; ----- Print herald -----

(COND (*LOAD-VERBOSE*
       (TERPRI)
       (PRINC 
	"BOOPS (c) 1992,1990,1989,1988 Koenraad De Smedt")))

;;; ----- Undefined -----

(DEFCONSTANT UNDEFINED 'UNDEFINED
  "The value returned from an object-oriented function call
   when the aspect is not defined for the object.")

;;; ----- Access to internal components of objects -----

;;; the ISA of an object is another object
;;; only single inheritance is supported

(DEFMACRO OBJECT-ISA (OBJECT)
  "Find isa in an object."
  `(GET ,OBJECT 'ISA))

;;; ASPECTS of an object are a list
;;; each aspect consists of a name and a definition
;;; a definition consists of a type and a filler

(DEFMACRO OBJECT-ASPECTS (OBJECT)
  "Find aspects in an object."
  `(GET ,OBJECT 'ASPECTS))

(DEFMACRO FIND-ASPECT (OBJECT ASPECT-NAME)
  "Find aspect in an object."
  `(ASSOC ,ASPECT-NAME (OBJECT-ASPECTS ,OBJECT)))

(DEFMACRO ASPECT-NAME (ASPECT)
  "Return the name of this aspect."
  `(FIRST ,ASPECT))

(DEFMACRO ASPECT-DEFINITION (ASPECT)
  "Return the definition of this aspect, in terms of type and filler."
  `(REST ,ASPECT))

(DEFMACRO ASPECT-TYPE (ASPECT-DEFINITION)
  "Return the type of this aspect definition."
  `(FIRST ,ASPECT-DEFINITION))

(DEFMACRO ASPECT-FILLER (ASPECT-DEFINITION)
  "Return the filler of this aspect definition."
  `(REST ,ASPECT-DEFINITION))

(DEFMACRO MAKE-ASPECT-DEFINITION (TYPE FILLER)
  "Make aspect definition with given type and filler."
  `(CONS ,TYPE ,FILLER))

(DEFMACRO MAKE-ASPECT (NAME TYPE FILLER)
  "Make aspect with given name, type and filler."
  `(CONS ,NAME (MAKE-ASPECT-DEFINITION ,TYPE ,FILLER)))

;;; ----- Making delegation links -----

(DEFUN ISA (OBJECT ISA)
  "Establish an isa relation. The OBJECT will then by
   default delegate all aspects to the ISA."
  (COND ((OR (EQ OBJECT ISA)
	     (ISA? ISA OBJECT))
	 (WARN "Making ~A inherit from ~A would cause circularity."
	       OBJECT ISA))
	(T (SETF (OBJECT-ISA OBJECT) ISA))))

(DEFUN ISA? (OBJECT ISA)
  "True if OBJECT is indeed a object of ISA."
  (LET ((CURRENT-ISA (OBJECT-ISA OBJECT)))
    (COND ((EQ ISA CURRENT-ISA) T)
	  ((NULL CURRENT-ISA) NIL)
	  (T (ISA? CURRENT-ISA ISA)))))

;;; ----- Adding and removing aspects -----

(DEFUN ADD-ASPECT (OBJECT ASPECT-NAME FILLER TYPE)
  "Add an aspect to an object."
  (LET ((CURRENT-ASPECT (FIND-ASPECT OBJECT ASPECT-NAME)))
    (COND ((NULL CURRENT-ASPECT)
           ;; new aspect
           (SETF (OBJECT-ASPECTS OBJECT)
		 (CONS (MAKE-ASPECT ASPECT-NAME TYPE FILLER)
		       (OBJECT-ASPECTS OBJECT))))
          (T            ;there is already an aspect
            (LET ((CURRENT-DEFINITION (ASPECT-DEFINITION CURRENT-ASPECT)))
             (UNLESS (AND (EQ (ASPECT-TYPE CURRENT-DEFINITION) TYPE)
			  (EQ (ASPECT-FILLER CURRENT-DEFINITION) FILLER))
               ;; if type and filler are eq to those in current aspect,
               ;; do nothing
               ;; else replace the definition
               (SETF (ASPECT-DEFINITION CURRENT-ASPECT)
                     (MAKE-ASPECT-DEFINITION TYPE FILLER)))))))
  ASPECT-NAME)

;;; ----- Defining aspects -----

(DEFMACRO DEFASPECT (OBJECT ASPECT-NAME &REST DEFINITION)
  "Define an aspect. The aspect name and object are not evaluated.
   This macro has the following syntax:
        DEFASPECT aspect object [type] filler
   The aspect definition is associated with the given object.
   If the type is omitted, the default is :VALUE.
   The following keywords for explicit aspect types are possible:
        :VALUE filler
   The filler can be any Lisp object which is simply returned.
        :FUNCTION filler
   or   :FUNCTION ([var ...]) form ...
   The filler is a function which is to be applied. The filler is
   a function with the given lambda list and forms.
        :IF-NEEDED filler
   or   :IF-NEEDED ([var ...]) form ...
   Like :FUNCTION but the result is to be memoized."
  (EXPAND-DEFASPECT ASPECT-NAME `',OBJECT DEFINITION))

(DEFUN EXPAND-DEFASPECT (ASPECT-NAME OBJECT DEFINITION)
  "Expansion for DEFASPECT."
  (COND (DEFINITION			;not an empty definition
	 (EXPAND-ASPECT-DEFINITION
	   `',ASPECT-NAME OBJECT
	   (FIRST DEFINITION) (REST DEFINITION)))))

(DEFUN EXPAND-ASPECT-DEFINITION (ASPECT-NAME OBJECT TYPE FILLER-LIST)
  "Expansion for definition in DEFASPECT."
  (COND
     ((NULL FILLER-LIST)           ;implicit type :VALUE
        `(ADD-ASPECT ,OBJECT ,ASPECT-NAME ,TYPE :VALUE))
     (T                            ;explicit type
      (CASE TYPE
        (:VALUE
          `(ADD-ASPECT
             ,OBJECT ,ASPECT-NAME ,(FIRST FILLER-LIST) ,TYPE))
        ((:FUNCTION :IF-NEEDED)                ;expand both the same
         `(ADD-ASPECT
            ,OBJECT
	    ,ASPECT-NAME
            ,(COND ((NULL (REST FILLER-LIST))     ;just one element?
		    ;; assume it contains a function
		    (FIRST FILLER-LIST))
		   (T
		    ;; assume it contains a variable list and body
		    `#'(LAMBDA ,(FIRST FILLER-LIST)
			 ,@(REST FILLER-LIST))))
            ,TYPE))))))

;;; ----- Defining named objects -----

(DEFMACRO DEFOBJECT (NAME ISA &BODY ASPECTS)
  "Define a named BOOPS object by assigning isas and defining
   aspects. The arguments are not evaluated.
   A symbol is a isa, lists are aspect definitions. Example:
     (DEFOBJECT WOMAN PERSON (SEX 'FEMALE))
   Aspect definitions are processed as by DEFASPECT."
  `(PROGN
     (ISA ',NAME ',ISA)
     (SETF (OBJECT-ASPECTS ',NAME) NIL)
     ,@(EXPAND-ASPECT-DEFINITIONS ASPECTS `',NAME)
     ',NAME))

(DEFUN EXPAND-ASPECT-DEFINITIONS (ASPECT-DEFINITIONS OBJECT)
  "Expand isa and aspect definitions in object definition."
  (MAPCAR #'(LAMBDA (ASPECT-DEFINITION)
	      (EXPAND-DEFASPECT (FIRST ASPECT-DEFINITION)
				OBJECT
				(REST ASPECT-DEFINITION)))
	  ASPECT-DEFINITIONS))

;;; ----- Defining anonymous objects -----

(DEFMACRO A (ISA &REST ASPECTS)
  "Define an anonymous BOOPS object by assigning isas and
   defining aspects. The arguments are not evaluated.
   A symbol is a isa, lists are aspect definitions. Example:
     (A PERSON (SEX 'FEMALE))
   Aspect definitions are processed as by DEFASPECT."
   (LET ((OBJECT (GENSYM)))
     `(LET ((,OBJECT (GENSYM (STRING ',ISA))))
        (ISA ,OBJECT ',ISA)
       ,@(EXPAND-ASPECT-DEFINITIONS ASPECTS OBJECT)
       ,OBJECT)))

(DEFMACRO AN (ISA &REST ASPECTS)
  "Synonym of A."
  `(A ,ISA ,@ASPECTS))

(DEFMACRO EEN (ISA &REST ASPECTS)
  "Synonym of A for Dutch."
  `(A ,ISA ,@ASPECTS))

;;; ----- Message passing -----

(DEFUN MESSAGE (OBJECT ASPECT-NAME &REST ARGS)
  "Message passing. Get the definition of the aspect for the
   object (the first argument) and if it is a function, apply
   that function to all the arguments."
  (COND ((GET ASPECT-NAME 'TRACED)
	 (FORMAT *TRACE-OUTPUT* "~%-> ~A ~A ~A"
		 ASPECT-NAME OBJECT ARGS)))
  (LET ((DEFINITION (GET-DEFINITION ASPECT-NAME OBJECT)))
    (LET ((TYPE (ASPECT-TYPE (FIRST DEFINITION)))
	  (FILLER (ASPECT-FILLER (FIRST DEFINITION)))
	  (SOURCE (SECOND DEFINITION)))
      ;; perform action according to type
      (LET ((RESULT
	      (CASE TYPE
		(:VALUE FILLER)
		(:FUNCTION (APPLY FILLER (CONS OBJECT ARGS)))
		(:IF-NEEDED
		  (SETQ FILLER		;reuse variable filler
			(APPLY FILLER (CONS OBJECT ARGS)))
		  (COND ((AND SOURCE
			      (NOT (EQ FILLER UNDEFINED)))
			 ;; inherited and not undefined, so memoize
			 (ADD-ASPECT OBJECT ASPECT-NAME FILLER :VALUE)))
		  FILLER)
		(OTHERWISE UNDEFINED))))
	(COND ((GET ASPECT-NAME 'TRACED)
	       (FORMAT *TRACE-OUTPUT* "~%<- ~A ~A ~A"
		       ASPECT-NAME OBJECT RESULT)))
	RESULT))))

;;; ----- Retrieving the definition of an aspect for an object -----

(DEFUN GET-DEFINITION (ASPECT-NAME OBJECT)
  "Get the definition of an aspect for an object.
   Return a list of the definition and the object providing it (if found
   AND inherited, otherwise NIL)."
  (LET ((OWN-DEFINITION
	  (ASPECT-DEFINITION (FIND-ASPECT OBJECT ASPECT-NAME))))
    (COND (OWN-DEFINITION
	   (LIST OWN-DEFINITION NIL))
	  (T (GET-DEFINITION-FROM-ISA
	       ASPECT-NAME (OBJECT-ISA OBJECT))))))

(DEFUN GET-DEFINITION-FROM-ISA (ASPECT-NAME OBJECT)
  "Get the definition of an aspect from the isa of an object.
   Return a list of the definition and the object providing it or NIL."
  (COND ((NULL OBJECT) (LIST NIL NIL))
	(T
	 (LET ((ASPECT (FIND-ASPECT OBJECT ASPECT-NAME)))
	   (COND (ASPECT
		  (LIST (ASPECT-DEFINITION ASPECT)
			OBJECT))
		 (T
		  (GET-DEFINITION-FROM-ISA ASPECT-NAME
					   (OBJECT-ISA OBJECT))))))))

;;; ----- Tracing messages -----

(DEFMACRO TRACE-MESSAGE (MESSAGE)
  "Trace a message upon receipt and return of result."
  `(SETF (GET ',MESSAGE 'TRACED) T))

(DEFMACRO UNTRACE-MESSAGE (MESSAGE)
  "Untrace a message."
  `(SETF (GET ',MESSAGE 'TRACED) NIL))

;;; ----- The vanilla object -----

(DEFOBJECT OBJECT
	   NIL
  (SHOW
    :FUNCTION
    #'(LAMBDA (SELF &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
	"Display a description of the object to the output stream."
	(COND ((OBJECT-ISA SELF)
	       (FORMAT OUTPUT-STREAM "~&~S is a ~S"
		       SELF (OBJECT-ISA SELF))))
	(DOLIST (ASPECT (OBJECT-ASPECTS SELF))
	  (LET ((TYPE (ASPECT-TYPE (ASPECT-DEFINITION ASPECT)))
		(FILLER (ASPECT-FILLER (ASPECT-DEFINITION ASPECT))))
	    (FORMAT OUTPUT-STREAM "~&  aspect ~A ~S = ~S"
		    (ASPECT-NAME ASPECT) TYPE FILLER)))
	SELF))
  (SET-VALUE
    :FUNCTION
    #'(LAMBDA (SELF ASPECT-NAME NEW-VALUE)
	"Give the aspect a new value."
	(ADD-ASPECT SELF ASPECT-NAME NEW-VALUE :VALUE)
	(LIST ASPECT-NAME NEW-VALUE)))
  )

;;; possible extensions:
;;; - make objects inherit from vanilla object if not otherwise defined
;;; - make messages generic functions: (friend 'peter)
;;;   (advantage = you can apply, map, trace etc. like normal functions)
;;; - add roles (whose 'friend 'peter)
;;; - do multiple inheritance
;;; - implement DELETE-ASPECT, NOT-ISA, etc.