1 files changed, 528 insertions, 0 deletions
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
new file mode 100644
index 0000000..4ff3d23
--- /dev/null
+++ b/modules/oop/pf-objects.scm
@@ -0,0 +1,528 @@
+(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-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+                
+(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 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 <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 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 <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-syntax make-pf-class
+    (lambda (x)
+      (syntax-case x ()
+        ((_ name const dynamic (supers (... ...)))
+         (with-syntax (((sups (... ...)) (generate-temporaries
+                                          #'(supers (... ...)))))
+           #'(let ((sups supers) (... ...))
+               (define class dynamic)
+               (define-class name (sups (... ...) <pf>))
+               (put! class.__const__
+                     (union const
+                            (let lp ((sup (list sups (... ...))))
+                              (if (pair? sup)
+                                  (union (ref (car sup) '__const__  null)
+                                         (lp (cdr sup)))
+                                  null))))
+  
+               (reshape (get class.__const__ null))
+               
+               (put! class.__goops__    name)
+               (put! class.__name__     'name)
+               (put! class.__parents__  (list sups (... ...)))
+               
+               (put! class.__const__.__name__    (cons 'name 'obj))
+               (put! class.__const__.__class__   class)
+               (put! class.__const__.__parents__ (list sups (... ...)))
+               class)))))))
+
+(mk-pf make-pf-class <pf>)
+(mk-pf make-pyf-class <pyf>)
+
+(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 class dynamic)
+               (define-class name (sups (... ...) <p>))
+               (put! class.__const__
+                     (union- const
+                             (let lp ((sup (list sups (... ...))))
+                               (if (pair? sup)
+                                   (union- (ref (car sup) '__const__  null)
+                                           (lp (cdr sup)))
+                                   (make-p)))))
+    
+
+               (put! class.__goops__    name)
+               (put! class.__name__     'name)
+               (put! class.__parents__  (list sups (... ...)))
+
+               (put! class.__const__.__name__    (cons 'name 'obj))
+               (put! class.__const__.__class__   class)
+               (put! class.__const__.__parents__ (list sups (... ...)))
+             
+               (union- class (get class.__const__)))))))))
+         
+(mk-p  make-p-class  <p>)
+(mk-p  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 x.__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! k.__class__ x)
+    (apply (ref k '__init__ (lambda x (values))) k l)
+    k))
+
+;; 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
+        (make-pf-class name
+                     (let ((s (make-pf)))
+                       (set s 'mname sval) (... ...)
+                       s)
+                     (let ((d (make-pf)))
+                       (set d 'dname dval) (... ...)
+                       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-syntax-rule (wrap class)
+  (let* ((c   class)
+         (ret (lambda x (apply mk c x))))
+    (set-procedure-property! ret 'pyclass class)
+    ret))
+
+(define (get-class x)
+  (aif it (procedure-property x 'pyclass)
+       it
+       (error "not a class")))
+
+