;;;==========================================
;;;
;;; SOOPS
;;; Simple Object-Orient Programming System
;;;
;;; written by manual chair japan
;;;
;;;==========================================

;|
;;;------------------------------------------
;;; usage
;;;------------------------------------------
;;; define class
;;;------------------------------------------

_$ (class 'soops:animal nil '((type . "unknown") (position quote (0.0 0.0 0.0))))
(CLASSINFO nil ((TYPE . "unknown") (POSITION QUOTE (0.0 0.0 0.0))) nil)
_$ (class 'soops:birds '(soops:animal) nil)
(CLASSINFO (SOOPS:ANIMAL) nil nil)
_$ (class 'soops:mammals '(soops:animal) nil)
(CLASSINFO (SOOPS:ANIMAL) nil nil)
_$ (class 'soops:bats '(soops:mammals soops:birds) '((type . "BATS")))
(CLASSINFO (SOOPS:MAMMALS SOOPS:BIRDS) ((TYPE . "BATS")) nil)

;;;------------------------------------------
;;; define method
;;;------------------------------------------

_$ (append-method
  'soops:animal
  'walk
  (function
    (lambda (handle vector / pos)
      (princ (strcat (property handle 'type) " walk.\n"))
      (setq pos (property handle 'position))
      (set-property
        handle
        'position
        (list (+ (car pos) (car vector)) (+ (cadr pos) (cadr vector)) 0.0)
      )
      handle
    )
  )
)

(CLASSINFO nil ((TYPE . "unknown") (POSITION QUOTE (0.0 0.0 0.0))) ((WALK QUOTE #<USUBR @0000000003328250 -lambda->)))
_$ (append-method
  'soops:birds
  'fly
  (function (lambda (handle vector / pos)
              (princ (strcat (property handle 'type) " fly.\n"))
              (setq pos (property handle 'position))
              (set-property
                handle
                'position
                (list (+ (car pos) (car vector))
                      (+ (cadr pos) (cadr vector))
                      (+ (caddr pos) (caddr vector))
                )
              )
              handle
            )
  )
)
(CLASSINFO (SOOPS:ANIMAL) nil ((FLY QUOTE #<USUBR @00000000033287c8 -lambda->)))

;;;------------------------------------------
;;; create & free instance
;;;------------------------------------------

_$ (setq adog (instance 'soops:mammals '((type . "DOGS"))))
*SOOPS:HND-0*
_$ (setq ahawk (instance 'soops:birds '((type . "HAWKS"))))
*SOOPS:HND-1*
_$ (setq abat (instance 'soops:bats nil))
*SOOPS:HND-2*
_$ (free adog)
nil
_$ (free ahawk)
nil
_$ (free abat)
nil

;;;------------------------------------------
;;; access property
;;;------------------------------------------

_$ (class-p adog 'soops:mammals)
T
_$ (class-p adog 'soops:birds)
nil

_$ (progeny-p adog 'soops:animal)
T
_$ (progeny-p adog 'soops:birds)
nil
_$ (progeny-p abat 'soops:mammals)
T
_$ (progeny-p abat 'soops:birds)
T

_$ (instance->alist adog)
((CLASS . SOOPS:MAMMALS) (POSITION 0.0 0.0 0.0) (TYPE . "DOGS"))

_$ (property ahawk 'type)
"HAWKS"
_$ (property abat 'type)
"BATS"
_$ (set-property ahawk 'type "falcon")
*SOOPS:HND-1*
_$ (property ahawk 'type)
"falcon"

;;;------------------------------------------
;;; call method
;;;------------------------------------------

_$ (invoke adog 'walk '((20.0 0.0 50.0)))
DOGS walk.
*SOOPS:HND-0*
_$ (property adog 'position)
(20.0 0.0 0.0)
_$ (invoke ahawk 'walk '((20.0 0.0 50.0)))
HAWKS walk.
*SOOPS:HND-1*
_$ (property ahawk 'position)
(20.0 0.0 0.0)
_$ (invoke ahawk 'fly '((20.0 0.0 50.0)))
falcon fly.
*SOOPS:HND-1*
_$ (property ahawk 'position)
(40.0 0.0 50.0)
_$ (invoke abat 'fly '((20.0 0.0 50.0)))
BATS fly.
*SOOPS:HND-2*
_$ (property abat 'position)
(20.0 0.0 50.0)

;;;------------------------------------------
;;; Multiple inheritance & next-funcall
;;;------------------------------------------

_$ (append-method
  'soops:animal
  'sayFeature
  (function (lambda (handle) (princ "We are organisms that move.\n") handle)
  )
)
(CLASSINFO nil ((TYPE . "unknown") (POSITION QUOTE (0.0 0.0 0.0))) ((SAYFEATURE QUOTE #<USUBR @000000002d927728 -lambda->) (WALK QUOTE #<USUBR @0000000003328250 -lambda->)))
_$ (append-method
  'soops:mammals
  'sayFeature
  (function (lambda (handle) (princ "We breastfeed.\n") (next-funcall)))
)
(CLASSINFO (SOOPS:ANIMAL) nil ((SAYFEATURE QUOTE #<USUBR @000000002d927cc8 -lambda->)))
_$ (append-method
  'soops:birds
  'sayFeature
  (function (lambda (handle)
              (princ "Most of us can fly in the sky.\n")
              (next-funcall)
            )
  )
)
(CLASSINFO (SOOPS:ANIMAL) nil ((SAYFEATURE QUOTE #<USUBR @00000000029351d8 -lambda->) (FLY QUOTE #<USUBR @00000000033287c8 -lambda->)))
_$ (invoke adog 'sayFeature nil)
We breastfeed.
We are organisms that move.
*SOOPS:HND-0*
_$ (invoke ahawk 'sayFeature nil)
Most of us can fly in the sky.
We are organisms that move.
*SOOPS:HND-1*
_$ (invoke abat 'sayFeature nil)
We breastfeed.
Most of us can fly in the sky.
We are organisms that move.
*SOOPS:HND-2*

;;;==========================================
|;

;;;
;;; support functions
;;;

(setq *soops:handleCount* 0)

(defun soops:getHandle (data / handle)
  (while (boundp
           (setq
             handle (read
                      (strcat "*soops:HND-" (itoa *soops:handleCount*) "*")
                    )
           )
         )
    (setq *soops:handleCount* (1+ *soops:handleCount*))
  )
  (set handle data)
  handle
)

(defun delete-duplicates (alist)
  (if alist
    (if (member (car alist) (cdr alist))
      (delete-duplicates (cdr alist))
      (cons (car alist) (delete-duplicates (cdr alist)))
    )
  )
)


;;;
;;; define class
;;;

(defun class (className parents properties / old-definition)
  (setq old-definition (vl-symbol-value className))
  (set className
       ;;(ClassInfo (parents) (properties) (method))
       (list 'ClassInfo
             parents
             properties
             (if old-definition
               (nth 3 ;|method|; old-definition)
             )
       )
  )
)

;;;
;;; define method
;;;

(defun append-method
       (className methodName func / ClassInfo-s method new old)
  (setq ClassInfo-s (vl-symbol-value className))
  (set className
       (list 'ClassInfo
             (nth 1 ;|parents|; ClassInfo-s)
             (nth 2 ;|layout|; ClassInfo-s)
             (if (setq method (nth 3 ;|method|; ClassInfo-s)
                       new    (cons methodName (list 'quote (eval func)))
                       old    (assoc methodName method)
                 )
               (subst new old method)
               (cons new method)
             )
       )
  )
)

(defun remove-method (className methodName / ClassInfo-s method old)
  (setq ClassInfo-s (vl-symbol-value className))
  (set className
       (list 'ClassInfo
             (nth 1 ;|parents|; ClassInfo-s)
             (nth 2 ;|layout|; ClassInfo-s)
             (if (setq method (nth 3 ;|method|; ClassInfo-s)
                       old    (assoc methodName method)
                 )
               (vl-remove old method)
               method
             )
       )
  )
)

;;;
;;; create instance
;;;

(defun inheritance-rank:sub (className)
  (if className
    (cons
      className
      (apply 'append
             (mapcar 'inheritance-rank:sub
                     (nth 1 ;|parents|; (vl-symbol-value className))
             )
      )
    )
  )
)

(defun inheritance-rank (className)
  (delete-duplicates (inheritance-rank:sub className))
)

;;

(defun instance:collect-property (className / cell property)
  (foreach cell (nth 2 ;|layout|; (vl-symbol-value className))
    (cond ((assoc (car cell) collection))
          ((setq property (assoc (car cell) initial-values))
           (setq collection     (cons property collection)
                 initial-values (vl-remove property initial-values)
           )
          )
          (T
           (setq collection
                  (cons (cons (car cell) (eval (cdr cell)))
                        collection
                  )
           )
          )
    )
  )
)

(defun instance (className initial-values / aclass collection)
  (foreach aclass (inheritance-rank className)
    (instance:collect-property aclass)
  )
  (soops:getHandle (cons className collection))
)

(defun free (handle) (set handle nil))

(defun class-p (handle className)
  (= (car (vl-symbol-value handle)) className)
)

(defun progeny-p (handle parentName)
  (and
    (member parentName
            (inheritance-rank (car (vl-symbol-value handle)))
    )
  )
)

(defun instance->alist (handle / record)
  (setq record (vl-symbol-value handle))
  (cons (cons 'class (car record)) (cdr record))
)

;;;
;;; property access
;;;

(defun property (handle propertyName)
  (cdr (assoc propertyName (cdr (vl-symbol-value handle))))
)

(defun set-property (handle propertyName value / cell record)
  (if (and (setq record (vl-symbol-value handle))
           (setq cell (assoc propertyName (cdr record)))
      )
    (set handle
         (cons (car record)
               (subst (cons propertyName value) cell (cdr record))
         )
    )
  )
  handle
)

;;;
;;; invoke method
;;;

(defun invoke:search-method (/ classinfo method)
  (if $_search-pass
    (if (setq classinfo     (vl-symbol-value (car $_search-pass))
              $_search-pass (cdr $_search-pass)
              method        (assoc $_methodName (nth 3 ;|method|; classinfo))
        )
      (cdr method)
      (invoke:search-method)
    )
  )
)

(defun invoke ($_handle        $_methodName    $_arglist
               /               $_search-pass   next-funcall
              )
  (if (and $_handle (vl-symbol-value $_handle))
    (progn (setq $_search-pass (inheritance-rank
                                 (car (vl-symbol-value $_handle))
                               )
                 next-funcall  (lambda (/ $_func)
                                 (if (setq $_func (invoke:search-method))
                                   (apply $_func (cons $_handle $_arglist))
                                 )
                               )
           )
           (next-funcall)
    )
  )
)