(load "expand-only.ss")
;(print-gensym #f)

;----------------------------------------------------------
(define field-ids car)
(define field-vals car)
(define method-table cdr)
(define method-ids cadr)
(define method-vals caddr)
(define cons-o cons)
(define cons-c cons)
(define cons-method-table list)
(define d->so datum->syntax-object)
(define so->d syntax-object->datum)
;---------------------------------------------------------

(define +f  ;;; returns let pairs ([f-id int] ...)
  (lambda (super f-ids)
    (let loop ([i 0] [sf-ids (vector->list (field-ids super))])
      (cond
        [(null? sf-ids)
         (let finish ([i i] [f-ids f-ids])
           (cond
             [(null? f-ids) '()]
             [else (cons `[,(car f-ids) ,i] (finish (+ i 1) (cdr f-ids)))]))]
        [else (cons `[,(car sf-ids) ,i] (loop (+ i 1) (cdr sf-ids)))]))))

(define +m  ;;; returns triples ([m-id int {m-id or (:m super m-id)}] ...)
  (lambda (super m-ids)
    (let loop ([i 0] [sm-ids (vector->list (method-ids super))] [m-ids m-ids])
      (cond
        [(null? sm-ids)
         (let finish ([i i] [m-ids m-ids])
           (cond
             [(null? m-ids) '()]
             [else (cons `[,(car m-ids) ,i ,(car m-ids)]
		     (finish (+ i 1) (cdr m-ids)))]))]
        [(memv (car sm-ids) m-ids)
         (cons `[,(car sm-ids) ,i ,(car sm-ids)]
           (loop (+ i 1) (cdr sm-ids) (remv (car sm-ids) m-ids)))]
        [else (cons `[,(car sm-ids) ,i (:m super ,(car sm-ids))]
		(loop (+ i 1) (cdr sm-ids) m-ids))]))))

(define-syntax method
  (lambda (x)
    (syntax-case x ()
      [(_ args body0 body1 ...)
       (with-syntax ([this (d->so #'_ 'this)])
         #'(lambda (this . args) body0 body1 ...))])))

(define objectx
  (expand
    '(define <object>
       (lets ([init (method args #t)]
	     [isa? (method (c) (eq? <object> c))])
	 (cons-c (vector)
	   (cons-method-table (vector 'init 'isa?) (vector init isa?)))))))

(pretty-print objectx)

(eval objectx)

(define :m
  (lambda (o/c m-id)
    (vector-ref (method-vals o/c) m-id)))

(define :f
  (lambda (o f-id) 
    (vector-ref (field-ids o) f-id)))

(define :f!
  (lambda (o f-id v) 
    (vector-set! (field-ids o) f-id v)))

(define :n
  (lambda (c)
    (cons-o (make-vector (vector-length (field-ids c))) (method-table c))))

(define-syntax new
  (syntax-rules ()
    [(_ c a ...)
     (let ([init 0])
       (let ([o (:n c)])
         ((:m o init) o a ...)
         o))]))

(define-syntax @@m ;;; should only be used for external calls.
  (syntax-rules ()
    [(_ o m-id a ...) ((::m o 'm-id) o a ...)]))

(define-syntax @m
  (syntax-rules ()
    [(_ o m-id a ...) ((:m o m-id) o a ...)]))

(define-syntax @s
  (lambda (x)
    (syntax-case x ()
      [(_ m-id a ...)
       (with-syntax ([super (d->so #'_ 'super)] [this (d->so #'_ 'this)])
	 #'((:m super m-id) this a ...))])))

(define ::m
  (lambda (o m-id)
    (let ([m-ids (method-ids o)])
      (:m o (- (vector-length m-ids) (length (memv m-id (vector->list m-ids))))))))
  
;;;;;  Test Programs

(define-syntax def-class
  (lambda (x)
    (syntax-case x ()
      [(_ host sup (f-id* ...) ([m-id* meth-exp*] ...))
       (let ([sup-c (eval (so->d #'sup))])
	 (printf "got past eval")
         (with-syntax
	   ([super (d->so #'_ 'super)]
	    [isa? (d->so #'_ 'isa?)]
	    [([f j] ...)
	     (d->so #'_ (+f sup-c (so->d #'(f-id* ...))))]
	    [([m i sm] ...)
	     (d->so #'_ (+m sup-c (so->d #'(isa? m-id* ...))))])
	   #'(define host
	       (let*s ([f j] ...)
		 (lets ([m i] ...)
		   (lets ([super sup])
		     (lets ([isa? (method (c) (or (eq? c host) ((:m super isa?) this c)))]
			   [m-id* meth-exp*] ...)
		       (cons-c (vector 'f ...)
			 (cons-method-table (vector 'm ...)
			   (vector sm ...))))))))))])))

(define ax
  (expand-only '(def-class)
    '(def-class <a> <object> (i j)
       ([setup (method (x)
                 (:f! this i 15)
                 (:f! this j 20)
                 x)]
        [f (method ()
             ((:m this g) this))] 
        [g (method ()
             (+ (:f this i) (:f this j)))]))))

(pretty-print ax)

(eval ax)

(define bx
  (expand-only '(def-class)
    '(def-class <b> <a> (j k)
       ([setup (method (x)
		 (:f! this j 100)
		 (:f! this k 200)
		 ((:m super setup) this x)
		 ((:m this h) this))]
	[g (method ()
	     (write (if ((:m this isa?) this <a>) 'yes 'no))
	     (newline)
	     (list
	       (:f this i)
	       (:f this j)
	       (:f this k)))]
	[h (method ()
	     ((:m super g) this))]))))

(pretty-print bx)

(eval bx)

(define cx
  (expand-only '(def-class)
    '(def-class <c> <b> ()
       ([g (method () ((:m super setup) this 5))]
        [h (method () (+ (:f this k) (:f this j)))]))))

(pretty-print cx)

(eval cx)

(define test
  (lambda ()
    (let ([p (lambda (o)
               (let ([u (@@m o setup 50)])
                 (list u (@@m o g) (@@m o f))))])
      (let ([oa (new <a>)] [ob (new <b>)] [oc (new <c>)])
        (pretty-print (p oa)) (pretty-print oa) (newline)
        (pretty-print (p ob)) (pretty-print ob) (newline)
        (pretty-print (p oc)) (pretty-print oc)))))

(test)

(define test2
  (lambda ()
    (let ([o (new <b>)]) ((::m o 'isa?) o <a>))))

(write (test2))
(newline)