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

(define-module (oop pf-objects)
  #:use-module (oop goops)
  #:use-module (ice-9 vlist)
  #:export (set ref make-pf <pf> call with copy fset fcall make-p put put!
                pcall pcall! get
                mk
                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

#|
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-class <p> () 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>))

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

(define (make-p)
  (define r (make <p>))
  (slot-set! r 'h make-hash-table)
  r)

(define fail (cons 'fail '()))
(define-syntax-rule (mrefx x key l)
  (let ((h (slot-ref x 'h)))
    (define pair (vhash-assq key h))
    (define (end)
      (if (null? l)
          #f
          (car l)))
    (define (parents)
      (let ((pair (vhash-assq '__parents__ h)))
        (if (pair? pair)
            (let lp ((li (cdr pair)))
              (if (pair? li)
                  (let ((r (ref (car li) key fail)))
                    (if (eq? r fail)
                        (lp (cdr li))
                        r))
                  (end)))
            (end))))

    (if pair
        (cdr pair)
        (let ((cl (ref x '__class__)))
          (if cl
              (let ((r (ref cl key) fail))
                (if (eq? r fail)
                    (parents)
                    r))
              (parents))))))

(define-syntax-rule (mrefx- x key l)
  (let* ((h (slot-ref x 'h))
         (r (hash-ref x key fail)))
    (if (eq? r fail)
        (if (pair? l)
            (car l)
            #f)
        r))))

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

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

(define-syntax-rule (mrefx-py x key l)
  (let ((f (mref x '__ref__)))
    (if (or (not f) (eq? f not-implemented))
        (mref    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 (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-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))



;; 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 '__set__)))
    (if (or (eq? f not-implemented) (not f))
        (mset x key val)
        (f key val))))
        

(define-syntax-rule (mset- x key val)
  (let ((h (slot-ref x 'h)))
    (hash-set! h key val)))

(define-syntax-rule (mset-py- x key val)
  (let ((f (mref-py- x '__set__)))
    (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 y 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 <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))

;; 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
(define-syntax-rule (mk-arith + +x __add__ __radd__)
  (begin
    (define-method (+ (x <p>) y)
      (call x '__add__ y))

    (define-method (+ x (y <p>))
      (call y '__radd__ x))

    (define-method (+ (x <py>) y)
      (let ((f (mref-py- x '__add__)))
        (if f
            (f y)
            (+x y x))))

    (define-method (+ (x <pyf>) y)
      (let ((f (mref-py x '__add__)))
        (if f
            (let ((res (f y)))
              (if (eq? res not-implemented)                  
                  (+x y x)
                  res))
            (+x y x))))

    (define-method (+ (x <py>) y)
      (let ((f (mref-py- x '__add__)))
        (if f
            (let ((res (f y)))
              (if (eq? res not-implemented)                  
                  (+x y x)
                  res))
            (+x y x))))
    
    (define-method (+ x (y <py>))
      (call y '__radd__ x))

    (define-method (+ x (y <pyf>))
      (call y '__radd__ x))
    
    (define-method (+x (x <p>) y)
      (call x '__radd__ y))))

;; A few arithmetic operations at service
(mk-arith + +x __add__ __radd__)
(mk-arith - -x __sub__ __rsub__)
(mk-arith * *x __mul__ __rmul__)

;; 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 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 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 <pf>))
  (slot-set! out 'h h)
  (slot-set! out 'n n)
  (slot-set! out 'size s)
  out)

(define (union- x y)
  (define hx (slot-ref x 'h))
  (define hy (slot-ref y 'h))  
  (define out (make <p>))
  (hash-for-each (lambda (k v) (hash-set! hy k v)) hx)
  (slot-set! out 'h hy)
  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 (make-pf-class name const dynamic supers)
    (define class dynamic)
    (define-class <pf> (<pf>))
    (put! class.__const__
          (union const
                 (let lp ((sup supers))
                   (if (pair? sup)
                       (union (ref (car sup) '__const__  null)
                              (lp (cdr supers)))
                       null))))
  
    (reshape (get class.__const__ null))

    (put! class.__goops__    <pf>)
    (put! class.__name__     name)
    (put! class.__parents__  supers)

    (put! class.__const__.__name__    (cons name 'obj))
    (put! class.__const__.__class__   class)
    (put! class.__const__.__parents__ supers)
    class))

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

(define-syntax-rule (mk-p make-p-class <p>)
  (define (make-p-class name const dynamic supers)
    (define class dynamic)
    (define-class <p> (<p>))
    (put! class.__const__
          (union- const
                  (let lp ((sup supers))
                    (if (pair? sup)
                        (union- (ref (car sup) '__const__  null)
                                (lp (cdr supers)))
                        (make-p)))))
    

    (put! class.__goops__    <p>)
    (put! class.__name__     name)
    (put! class.__parents__  supers)

    (put! class.__const__.__name__    (cons name 'obj))
    (put! class.__const__.__class__   class)
    (put! class.__const__.__parents__ supers)
  
    (union- class (get class.__const__))))

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

;; Let's make an object essentially just move a reference
(define-method (mk (x <pf>) . l)
  (let ((r (get x.__const__))
        (k (make (get class.__goops__))))
    (slot-set! k 'h (slot-ref r 'h))
    (slot-set! k 'size (slot-ref r 'size))
    (slot-set! k 'n (slot-ref r 'n))
    (apply (ref k '__init__ (lambda x (values))) k l)
    k))

(define-method (mk (x <p>) . l)
  (let ((k (make (get x.__goops__))))
    (put! r.__class__ x)
    (apply (ref r '__init__ (lambda x (values))) r l)
    r))

;; the make class and defclass syntactic sugar
(define-syntax-rule (mk-p/f 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
        (make-pf-class 'name
                       (let ((s (make-pf)))
                         (set s 'mname sval) (... ...)
                         s)
                       (let ((d (make-pf)))
                         (set d 'dname dval) (... ...)
                         d)                 
                       (list parents (... ...))))
      name)))

(mk-p/f mk-pf-class  make-pf-class)
(mk-p/f mk-p-class   make-p-class)
(mk-p/f mk-pyf-class make-pyf-class)
(mk-p/f 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)))