path: root/modules/oop/pf-objects.scm

(define-module (oop pf-objects)
  #:use-module (oop goops)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
  #:export (set ref make-pf <p> <py> <pf> <pyf>
                call with copy fset fcall make-p put put!
                pcall pcall! get fset-x pyclass? refq
                def-pf-class  mk-pf-class  make-pf-class
                def-p-class   mk-p-class   make-p-class
                def-pyf-class mk-pyf-class make-pyf-class
                def-py-class  mk-py-class  make-py-class
                define-python-class get-type py-class
                ))
#|
Python object system is basically syntactic suger otop of a hashmap and one
this project is inspired by the python object system and what it measn when
one in stead of hasmaps use functional hashmaps. We use vhashes, but those have a drawback in that those are not thread safe. But it is a small effort to work
with assocs or tree like functional hashmaps in stead.

The hashmap works like an assoc e.g. we will define new values by 'consing' a
new binding on the list and when the assoc take up too much space it will be
reshaped and all extra bindings will be removed.

The datastructure is functional but the objects mutate. So one need to 
explicitly tell it to not update etc.
|#

(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
(define-class <p>  (<applicable-struct>) h)
(define-class <pf> (<p>) size n)         ; the pf object consist of a functional
                                         ; hashmap it's size and number of live
                                         ; object
(define-class <py>  (<p>))
(define-class <pyf> (<pf>))

(define (mk x)
  (letrec ((o (make (ref x '__goops__))))
    (slot-set! o 'procedure
               (lambda x
                 (apply
                  (ref o '__call__ (lambda x (error "no __call__ method")))
                  x)))
    (cond
     ((is-a? x <pf>)
      (let ((r (ref x '__const__)))
        (slot-set! o 'h    (slot-ref r 'h))
        (slot-set! o 'size (slot-ref r 'size))
        (slot-set! o 'n    (slot-ref r 'n))
        o))
     
     ((is-a? x <p>)
      (let ((r (ref x '__const__))
            (h (make-hash-table)))        
        (hash-set! h '__class__ x)
        (slot-set! o 'h    h))
      o))))
          
(define (make-pyclass x)
  (letrec ((class (make x)))
    (slot-set! class 'procedure
               (lambda x
                 (let ((obj (mk class)))
                   (aif it (ref obj '__init__)
                        (apply it x)
                        (values))
                   obj)))
    class))

;; Make an empty pf object
(define* (make-pf #:optional (class <pf>))
  (define r (make-pyclass class))
  (slot-set! r 'h vlist-null)
  (slot-set! r 'size 0)
  (slot-set! r 'n 0)
  r)

(define* (make-p #:optional (class <p>))
  (define r (make-pyclass class))
  (slot-set! r 'h (make-hash-table))
  r)

(define-syntax-rule (hif it (k h) x y)
  (let ((a (vhash-assq k h)))
    (if (pair? a)
        (let ((it (cdr a)))
          x)
        y)))

(define-syntax-rule (cif (it h) (k cl) x y)
  (let* ((h (slot-ref cl 'h))
         (a (vhash-assq k h)))
    (if (pair? a)
        (let ((it (cdr a)))
          x)
        y)))

(define fail (cons 'fail '()))
(define-syntax-rule (mrefx x key l)
  (let ()
    (define (end)
      (if (null? l)
          #f
          (car l)))

    (define (parents li)
      (let lp ((li li))
        (if (pair? li)
            (let ((p (car li)))
              (cif (it h) (key p)
                   it
                   (hif it ('__parents__ h)
                        (let ((r (parents it)))
                          (if (eq? r fail)
                              (lp (cdr li))
                              r))
                        (lp (cdr li)))))
            fail)))
  
    (cif (it h) (key x)
         it
         (hif cl ('__class__ h)
              (cif (it h) (key cl)
                   it
                   (hif p ('__parents__ h)
                        (let ((r (parents p)))
                          (if (eq? r fail)
                              (end)
                              r))
                        (end)))
              (end)))))

(define-syntax-rule (mrefx- x key l) (mrefx-- (slot-ref x 'h) key l))
(define-syntax-rule (mrefx-- hi key l)
  (let ()
    (define (end)   (if (pair? l) (car l) #f))
    (define (ret q) (if (eq? q fail) (end) q))
    
    (define (find-in-class h)
      (let lp ((class-h h))
        (let ((r (hash-ref class-h key fail)))
          (if (eq? r fail)
              (aif parents (hash-ref class-h '__parents__ #f)
                   (let lpp ((parents parents))
                     (if (pair? parents)
                         (let ((parent (car parents)))
                           (let ((r (lp (slot-ref parent 'h))))
                             (if (eq? r fail)
                                 (lpp (cdr parents))
                                 r)))
                         fail))
                   fail)
              r))))

    (let* ((h hi)
           (r (hash-ref h key fail)))
      (if (eq? r fail)
          (aif class (hash-ref h '__class__)
               (ret (find-in-class (slot-ref class 'h)))
               (end))
          r))))

(define not-implemented (cons 'not 'implemeneted))

(define-syntax-rule (mrefx-py- x key l)
  (let ((f (mrefx- x '__getattribute__ '())))
    (if (or (not f) (eq? f not-implemented))
        (mrefx- x key l)
        (apply f x key l))))

(define-syntax-rule (mrefx-py x key l)
  (let ((f (mrefx x '__getattribute__ '())))
    (if (or (not f) (eq? f not-implemented))
        (mrefx    x key l)
        (apply f x key l))))

(define-syntax-rule (unx mrefx- mref-)
  (define-syntax-rule (mref- x key l)
    (let ((xx x))
      (let ((res (mrefx- xx key l)))
        (if (and (not (struct? res)) (procedure? res))
            (lambda z
              (apply res xx z))
            res)))))

(unx mrefx-    mref-)
(unx mrefx     mref)
(unx mrefx-py  mref-py)
(unx mrefx-py- mref-py-)

(define-syntax-rule (unx mrefx- mref-)
  (define-syntax-rule (mref- x key l)
    (let ((xx x))
      (let ((res (mrefx- xx key l)))
        (if (and (not (struct? res))
                 (not (pyclass? res))
                 (procedure? res))
            (lambda z
              (apply res xx z))
            res)))))

(unx mrefx-    mref-q)
(unx mrefx     mrefq)
(unx mrefx-py  mref-pyq)
(unx mrefx-py- mref-py-q)

(define-method (ref (x <pf> )  key . l) (mref     x key l))
(define-method (ref (x <p>  )  key . l) (mref-    x key l))
(define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
(define-method (ref (x <py> )  key . l) (mref-py- x key l))

(define-method (refq (x <pf> )  key . l) (mrefq     x key l))
(define-method (refq (x <p>  )  key . l) (mref-q    x key l))
(define-method (refq (x <pyf>)  key . l) (mref-pyq  x key l))
(define-method (refq (x <py> )  key . l) (mref-py-q x key l))
      
;; the reshape function that will create a fresh new pf object with less size
;; this is an expensive operation and will only be done when we now there is
;; a lot to gain essentially tho complexity is as in the number of set
(define (reshape x)
  (let ((h (slot-ref x 'h))
        (m (make-hash-table))
        (n 0))
    (define h2 (vhash-fold (lambda (k v s)
                             (if (hash-ref m k #f)
                                 s
                                 (begin
                                   (hash-set! m k #t)
                                   (set! n (+ n 1))
                                   (vhash-consq k v s))))
                           vlist-null
                           h))
    (slot-set! x 'h h2)
    (slot-set! x 'size n)
    (slot-set! x 'n    n)
    (values)))

;; on object x add a binding that key -> val
(define-syntax-rule (mset x key val)
  (let ((h (slot-ref x 'h))
        (s (slot-ref x 'size))
        (n (slot-ref x 'n)))
    (slot-set! x 'size (+ 1 s))
    (let ((r (vhash-assq key h)))
      (when (not r)
        (slot-set! x 'n (+ n 1)))
      (slot-set! x 'h (vhash-consq key val h))
      (when (> s (* 2 n))
        (reshape x))
      (values))))

(define-syntax-rule (mset-py x key val)
  (let ((f (mref-py x '__setattr__ '())))
    (if (or (eq? f not-implemented) (not f))
        (mset x key val)
        (f key val))))

(define (pkh h) (hash-for-each (lambda x (pk x)) h) h)

(define-syntax-rule (mset- x key val)
  (let ()
    (define (s h) (begin (hash-set! h key val) #f))
    (define fret #t)
    (define (r h k) (hash-ref h k))
    (define-syntax-rule (ifh h fail-code)
      (if (r h key)
          (s h)
          fail-code))
          
    (define (hm x) (slot-ref x 'h))
    (let ((h (hm x)))
      (if (ifh h
               (aif it (r h '__class__)
                    (let lp ((cl it))
                      (let ((h (hm cl)))
                        (ifh h
                             (aif it (r h '__parents__)
                                  (let lp2 ((parents it))
                                    (if (pair? parents)
                                        (if (lp (car parents))
                                            (lp2 (cdr parents))
                                            fret)
                                        fret))
                                  fret))))
                    fret))
          (s h))
      (values))))

(define-syntax-rule (mset-py- x key val)
  (let ((f (mref-py- x '__setattr__ '())))
    (if (or (eq? f not-implemented) (not f))
        (mset- x key val)
        (f key val))))

(define-method (set (x <pf>)  key val) (mset     x key val))
(define-method (set (x <p>)   key val) (mset-    x key val))
(define-method (set (x <pyf>) key val) (mset-py  x key val))
(define-method (set (x <py>)  key val) (mset-py- x key val))

;; mref will reference the value of the key in the object x, an extra default
;; parameter will tell what the fail object is else #f if fail
;; if there is no found binding in the object search the class and
;; the super classes for a binding

;; call a function as a value of key in x with the object otself as a first
;; parameter, this is pythonic object semantics
(define-syntax-rule (mk-call mcall mref)
  (define-syntax-rule (mcall x key l)
    (apply (mref x key '()) l)))

(mk-call mcall     mref)
(mk-call mcall-    mref-)
(mk-call mcall-py  mref-py)
(mk-call mcall-py- mref-py-)
  
(define-method (call (x <pf>)  key . l) (mcall     x key l))
(define-method (call (x <p>)   key . l) (mcall-    x key l))
(define-method (call (x <pyf>) key . l) (mcall-py  x key l))
(define-method (call (x <py>)  key . l) (mcall-py- x key l))


;; make a copy of a pf object
(define-syntax-rule (mcopy x)
  (let ((r (make-pyclass <pf>)))
    (slot-set! r 'h (slot-ref x 'h))
    (slot-set! r 'size (slot-ref x 'size))
    (slot-set! r 'n (slot-ref x 'n))
    r))

(define-syntax-rule (mcopy- x)
  (let* ((r (make-p))
         (h (slot-ref r 'h)))
    (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
    r))

(define-method (copy (x <pf>)) (mcopy  x))
(define-method (copy (x <p> )) (mcopy- x))
  

;; with will execute thunk and restor x to it's initial state after it has
;; finished note that this is a cheap operatoin because we use a functional
;; datastructure
(define-syntax-rule (mwith x thunk)
  (let ((old (mcopy x)))
    (let ((r (thunk)))
      (slot-set! x 'h    (slot-ref old 'h))
      (slot-set! x 'size (slot-ref old 'size))    
      (slot-set! x 'n    (slot-ref old 'n))
      r)))

(define-syntax-rule (mwith- x thunk)
  (let ((old (mcopy- x)))
    (let ((r (thunk)))
      (slot-set! x 'h    (slot-ref old 'h))
      r)))



;; a functional set will return a new object with the added binding and keep
;; x untouched
(define-method (fset (x <pf>) key val)
  (let ((x (mcopy x)))
    (mset x key val)
    x))

(define-method (fset (x <p>) key val)
  (let ((x (mcopy- x)))
    (mset x key val)
    x))

(define (fset-x obj l val)
  (let lp ((obj obj) (l l) (r '()))
    (match l
      (()
       (let lp ((v val) (r r))
         (if (pair? r)
             (lp (fset (caar r) (cdar r) v) (cdr r))
             v)))
      ((k . l)
       (lp (ref obj k #f) l (cons (cons obj k) r))))))



           

;; a functional call will keep x untouched and return (values fknval newx)
;; e.g. we get both the value of the call and the new version of x with
;; perhaps new bindings added
(define-method (fcall (x <pf>) key . l)
  (let* ((y (mcopy x))
         (r (mcall y key l)))
    (if (eq? (slot-ref x 'h) (slot-ref y 'h))
        (values r x)
        (values r y))))

(define-method (fcall (x <p>) key . l)
  (let ((x (mcopy x)))
    (values (mcall- x key l)
            x)))

;; this shows how we can override addition in a pythonic way

;; lets define get put pcall etc so that we can refer to an object like
;; e.g. (put x.y.z 1) (pcall x.y 1)

(define-syntax-rule (cross x k f set)
  (call-with-values (lambda () f)
    (lambda (r y)
      (if (eq? x y)
          (values r x)
          (values r (set x k y))))))

(define-syntax-rule (cross! x k f _) f)

(define-syntax mku
  (syntax-rules ()
    ((_ cross set setx f (key) (val ...))
     (setx f key val ...))
    ((_ cross set setx f (k . l) val)
     (cross f k (mku cross set setx (ref f k) l val) set))))

(define-syntax-rule (mkk pset setx set cross)
  (define-syntax pset
    (lambda (x)   
      (syntax-case x ()
        ((_ f val (... ...))
         (let* ((to (lambda (x)
                      (datum->syntax #'f  (string->symbol x))))
                (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
           (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
                                             (cdr l)))
                         (h       (to (car l))))
             #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))

(mkk put    fset  fset cross)
(mkk put!   set   set  cross!)
(mkk pcall! call  fset cross!)
(mkk pcall  fcall fset cross)
(mkk get    ref   fset cross!)

;; it's good to have a null object so we don't need to construct it all the
;; time because it is functional we can get away with this.
(define null (make-pf))

;; append the bindings in x in front of y + some optimizations
(define (union x y)
  (define hx (slot-ref x 'h))
  (define hy (slot-ref y 'h))
  (define n  (slot-ref x 'n))
  (define s  (slot-ref x 'size))
  (define m (make-hash-table))

  (define h
    (vhash-fold
     (lambda (k v st)
       (if (vhash-assq k hy)
           (begin
             (set! s (+ s 1))
             (vhash-consq k v st))
           (if (hash-ref m k)
               s
               (begin
                 (set! n (+ n 1))
                 (set! s (+ s 1))
                 (hash-set! m k #t)
                 (vhash-consq k v st)))))
     hy
     hx))
  
  (define out (make-pyclass <pf>))
  (slot-set! out 'h h)
  (slot-set! out 'n n)
  (slot-set! out 'size s)
  out)

(define (union- class x y)
  (define hx (slot-ref x 'h))
  (define hy (slot-ref y 'h))  
  (define out (make-p class))
  (define h  (slot-ref out 'h))
  (hash-for-each (lambda (k v) (hash-set! h k v)) hy)
  (hash-for-each (lambda (k v) (hash-set! h k v)) hx)
  out)


;; make a class. A class add some meta information to allow for multiple
;; inherritance and add effectively static data to the object the functional
;; datastructure show it's effeciency now const is data that will not change
;; and bindings that are added to all objects. Dynamic is the mutating class
;; information. supers is a list of priorities
(define-syntax-rule (mk-pf make-pf-class <pf>)
  (define-syntax make-pf-class
    (lambda (x)
      (syntax-case x ()
        ((_ name const dynamic (supers (... ...)))
         (with-syntax (((sups (... ...)) (generate-temporaries
                                          #'(supers (... ...)))))
           #'(let ((sups supers) (... ...))
               (define name (make-class (list sups (... ...) <pf>) '()))
               (define class (dynamic name))
               (define __const__
                 (union const
                        (let lp ((sup (filter-parents
                                       (list sups (... ...)))))
                          (if (pair? sup)
                              (union (ref (car sup) '__const__  null)
                                     (lp (cdr sup)))
                              null))))
               
               (reshape __const__)
               (set  class '__const__    __const__)
               (set  class '__goops__    name)
               (set  class '__name__     'name)
               (set  class '__parents__  (filter-parents
                                          (list sups (... ...))))
               
               (set class '__goops__    name)
               (set  __const__ '__name__    'name)
               (set  __const__ '__goops__   class)
               (set  __const__ '__parents__ (filter-parents
                                             (list sups (... ...))))
               (set  __const__ '__goops__   name)
               class)))))))

(mk-pf make-pf-class <pf>)
(mk-pf make-pyf-class <pyf>)

(define (filter-parents l)
  (let lp ((l l))
    (if (pair? l)
        (if (is-a? (car l) <p>)
            (cons (car l) (lp (cdr l)))
            (lp (cdr l)))
        '())))

(define-syntax-rule (mk-p make-p-class <p>)
  (define-syntax make-p-class
    (lambda (x)
      (syntax-case x ()
        ((_ name const dynamic (supers (... ...)))
         (with-syntax (((sups (... ...)) (generate-temporaries
                                          #'(supers (... ...)))))
           #'(let ((sups supers) (... ...))
               (define name (make-class (list
                                         (if (is-a? sups <p>)
                                             (aif it (ref sups '__goops__ #f)
                                                  it
                                                  sups)
                                             sups)
                                         (... ...) <p>) '()))
               
               (define class (dynamic <p>))
               (set class '__name__    'name)
               (set class '__class__   #f)
               (set class '__goops__    name)
               (set class '__parents__  (filter-parents (list sups (... ...))))
               class)))))))

(mk-p  make-p-class  <p>)
(mk-p  make-py-class <py>)

;; Let's make an object essentially just move a reference

;; the make class and defclass syntactic sugar
(define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class)
  (define-syntax-rule (mk-pf-class name (parents (... ...))
                                   #:const
                                   ((sdef mname sval) (... ...))
                                   #:dynamic
                                   ((ddef dname dval) (... ...)))
    (let ()
      (define name 
        (letrec ((mname sval) (... ...) (dname dval) (... ...))
          (make-pf-class name
                         (let ((s (make-pf)))
                           (set s 'mname mname) (... ...)
                           s)
                         (lambda (class)
                           (let ((d (make-pf class)))
                             (set d 'dname dname) (... ...)
                             d))                 
                         (parents (... ...)))))
      name)))

(mk-p/f make-pf mk-pf-class  make-pf-class)
(mk-p/f make-p  mk-p-class   make-p-class)
(mk-p/f make-pf mk-pyf-class make-pyf-class)
(mk-p/f make-p  mk-py-class  make-py-class)

(define-syntax-rule (def-pf-class name . l)
  (define name (mk-pf-class name . l)))

(define-syntax-rule (def-p-class  name . l)
  (define name (mk-p-class name . l)))

(define-syntax-rule (def-pyf-class name . l)
  (define name (mk-pyf-class name . l)))

(define-syntax-rule (def-py-class  name . l)
  (define name (mk-py-class name . l)))

(define (get-class o)
  (cond
   ((is-a? o <p>)
    o)
   (else
    (error "not a pyclass"))))

(define (get-type o)
  (cond
   ((is-a? o <pyf>)
    'pyf)
   ((is-a? o <py>)
    'py)
   ((is-a? o <pf>)
    'pf)
   ((is-a? o <p>)
    'p)
   (else
    'none)))

(define (print o l)
  (define p1 (if (pyclass? o) "C" "O"))
  (define p2 (if (pyclass? o) "C" "O"))
  (define port (if (pair? l) (car l) #t))
  (format port "~a"
          (aif it (if (pyclass? o) #f (ref o '__repr__ #f))
               (format
                #f "~a(~a)<~a>" p1 (get-type o) (it))
               (format
                #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None)))))

(define-method (write (o <p>) . l) (print o l))
(define-method (display (o <p>) . l) (print o l))

(define-syntax-rule (define-python-class name parents code ...)
  (define name
    (mk-py-class name parents
                 #:const
                 ()
                 #:dynamic
                 (code ...))))

(define (pyclass? x)
  (and (is-a? x <p>)
       (not (ref x '__class__))))


(define-method (py-class (o <p>))
  (ref o '__class__ 'type))