Date fre 28 juli 2017

The python object model is a belowed object system and quite popular. The thing is that scheme is much much more elegant than python and to prove this we implement the python object model semantics in scheme and show how a functional python implementation can look like.

To start things up do

(use-modules (oop pf-objects))

Define a class

(defclass <a> ()
   #:const
   (
     (def val 1)
     (def __init__ (case-lambda
                     ((self)
                       (put! self.val 0))
                     ((self x)
                       (put! self.val x))))

    (def __add__   (lambda (self y)
                      (if (eq? (get self.__class__)
                               (get y.__class__))
                          (put! self.nops (+ (get self.nop) 1))
                          (put self.val (+ (get self.val) (get y.val)))
                          (put self.val (+ (get self.val) y)))))

    (def __radd__  (lambda (self y)
                     (put! self.nops (+ (get self.nop) 1))
                     (put self.val (+ (get self.val) y)))))


    #:dynamic
    (
       (def nops 0)
    ))

This shows typical python patterns. Note how put! will return a new fresh object with an added binding and how we define a dynamic variable that will collect the overall class data. We use it as:

>> (ref (+ (mk <a> 1) (mk <a> 2)) 'val)
3

>> (ref <a> 'nops)
2

>> (put! <a>.nops 0)

>> (with <a> (lambda () (+ (mk <a> 1) (+ (mk <a> 2)))))
3

>> (ref <a> 'nops)
0

This is already quite useful and much much more can be added. But I find it cool, I will continue to add to this and make it LGPL, Have fun!

The code:

(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 defclass mkclass make-pclass))

#|
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 <pf> () h size n)   ; the pf object consist of a functional
                                  ; hashmap it's size and number of live
                                  ; object

;; 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)

  ;; 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))))

;; let's define a method
(define-method (set (x <pf>) key val) (mset 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

(define fail (cons 'fail '()))
(define-syntax-rule (mref 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-method (ref (x <pf>) key . l) (mref x key l))

;; 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 (mcall x key l)
  (let ((y x))
    (apply (mref y key '()) y l)))

(define-method (call (x <pf>) key . l)
  (apply (mref 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-method (copy (x <pf>)) (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-method (with (x <pf>) thunk) (mwith x thunk))

;; a functional set will return a new object with the added binding and keep
;; x untouched
(define-method (fset (x <pf>) key val)
   (mwith x (lambda () (mset x key val) (mcopy 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)
  (mwith x
    (lambda ()
      (values (mcall x key l)
              (mcopy x)))))

;; this shows how we can override addition in a pythonic way
(define-method (+ (x <pf>) y)
   (call x '__add__ x y))

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

;; 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 mku
  (syntax-rules ()
      ((_ set f (key) (val ...))    (set f key val ...))
      ((_ set f (k . l) val)        (mku set (ref f k) l val))))

(define-syntax-rule (mkk pset set)
  (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 set h (a (... ...)) (val (... ...))))))))))

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

;; it's goofd 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)

;; make a class. A class add some meta information to allow for multiple
;; inherritance and add effectively const 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 (make-pclass name const dynamic supers)
  (define class dynamic)

  (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.__name__     name)
  (put! class.__parents__  supers)

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

;; Let's make an object essentially just move a reference
(define (mk class . l)
   (let ((r (copy (get class.__const__))))
     (apply (ref r '__init__ (lambda x (values))) r l)
     r))

;; the make class and defclass syntactic sugar
(define-syntax-rule (mkclass name (parents ...)
                  #:const
                  ((sdef mname sval) ...)
                  #:dynamic
                  ((ddef dname dval) ...))
   (let ()
     (define name
       (make-pclass 'name
               (let ((s (make-pf)))
                 (set s 'mname sval) ...
                 s)
               (let ((d (make-pf)))
                 (set d 'dname dval) ...
                 d)                 
               (list parents ...)))
     name))

(define-syntax-rule (defclass name . l) (define name (mkclass name . l)))

Comments

comments powered by Disqus

~ Follow me ~