;;
;;  Type classes for Scheme. Based on code from the comp.lang.scheme
;;  post by Andre van Tonder entitled "Typeclass envy".
;;
;;  Ported to Chicken Scheme by Ivan Raikov.
;;
;;  Copyright 2004-2011 Andre van Tonder, Ivan Raikov.
;;
;;  Permission is hereby granted, free of charge, to any person
;;  obtaining a copy of this software and associated documentation
;;  files (the "Software"), to deal in the Software without
;;  restriction, including without limitation the rights to use, copy,
;;  modify, merge, publish, distribute, sublicense, and/or sell copies
;;  of the Software, and to permit persons to whom the Software is
;;  furnished to do so, subject to the following conditions:
;;
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;  HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;  WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;  DEALINGS IN THE SOFTWARE.
;;  
;;

(import scheme typeclass srfi-1)

;=======================================================
; Equality example:

; class (Eq a) where
;   egal?     : a a -> boolean
;   not-egal? : a a -> boolean

(define-class <Eq> egal?
                   not-egal?)

(define (default-Eq egal?)
  (make-<Eq> egal?
             (lambda (x y) (not (egal? x y)))))

(define num-Eq (default-Eq =))
(define eqv-Eq (default-Eq eqv?))
(define chr-Eq (default-Eq char=?))
;======================================================
; Collections example;

; class (Collection a c) where
;   empty  : c
;   insert : a c -> c
;   ...

(define-class <Collection> empty
                           insert
                           fold)

; contains? : (Eq a) (Collection a c) => a c -> Bool

(define=> (contains? <Eq> <Collection>)
  (lambda (a c)
    (call/cc (lambda (break)
               (fold (lambda (x seed)
                       (if (egal? a x)
                           (break #t)
                           #f))
                     #f
                     c)))))

; class (Eq a) (Collection a) => (Set a s) where

(define-class <Set> (<Eq> eq)
                    (<Collection> coll))

; set-member? : (Set a s) => a s -> Bool

(define=> (set-member? <Set>)
  (contains? eq coll))    

; instance (Eq a) => Set a [a]


(define (list-Set eq)
  (let ((this (make-parameter #f)))
    (let ((empty  '())
          (insert (lambda (x s)
                    (if ((set-member? (this)) x s)
                        s (cons x s))))
          (fold   fold))
      (this (make-<Set> eq
                        (make-<Collection> empty
                                           insert
                                           fold)))
      (this))
    ))

; instance Set Num [Num]
; instance Set a [a]

(define num-Set (list-Set num-Eq))                            
(define eqv-Set (list-Set eqv-Eq))

; instance Set char string where ...

(define chr-Set
  (let ((this (make-parameter #f)))
    (letrec ((empty  "")
             (insert (lambda (x s)
                       (if ((set-member? (this)) x s)
                           s (string-append (string x) s))))
             (fold   (lambda (f seed s)
                       (let loop ((acc seed)
                                  (i 0))
                         (if (= i (string-length s))
                             acc
                             (loop (f (string-ref s i) acc)
                                   (+ i 1))))))
             )
      (this (make-<Set> chr-Eq
                        (make-<Collection> empty
                                           insert  
                                           fold)))
      (this))
    ))

; list->Set : (Set a s) => [a] -> s

(define=> (list->set <Set>)
  (lambda (lst)
    (fold (lambda (x s) (insert x s))
           empty
           lst)))

; heterogenous-union : (Set a sa) (Set b sb) => sa sb -> sa

(define=> (heterogenous-union (<Set> a.) (<Set> b.))
  (lambda (x y)
    (b.fold (lambda (elem accum)
              (a.insert elem accum))
            x
            y)))



;===============================================
; Extending the Set class:

; class (Set a s) => Set+ a s where
;   union : s s -> s
;   ...

(define-class <Set+> (<Set> set) union
                                 member?
                                 list->set)

; default-Set+ : (Set a s) -> (Set+ a s)

(define (default-Set+ sa)
  (make-<Set+> sa
               (heterogenous-union sa sa)
               (set-member? sa)
               (list->set sa)))


(define chr-Set+ (default-Set+ chr-Set))
(define num-Set+ (default-Set+ num-Set))

;----------------------------------------------------------
; Tests

(with-instance ((<Set> num-Set))
	       empty)                            ;==> ()

(print
((heterogenous-union eqv-Set chr-Set)
 '(1 2 3 4 5)
 "abcde")               ;==> (#\e #\d #\c #\b #\a 1 2 3 4 5)
)

(with-instance ((<Set+> num-Set+ num.)
		(<Set+> chr-Set+ chr.))
	       (values
		num.empty
		chr.empty))                     ;==> ()  ""


(import-instance (<Set+> num-Set+ num.)
		 (<Set+> chr-Set+ chr.))

(num.union '(1 2 3 4 5)
           '(3 4 5 6 7))            ;==>  (7 6 1 2 3 4 5)


(chr.list->set "abcda") ;==> "dcba"

(import-instance (<Set+> num-Set+))

(print
(union  '(1 2 3 4 5)
        '(2 3 4 5 7))               ;==> (7 1 2 3 4 5)
)

(print
(list->set '(1 1 2 3 4 3 4))        ;==> (4 3 2 1)
)



;==============================================================
; Extensible interpreter.

;------------------------------------
; Uses variant types as defined here.  

(define-syntax define-type
  (syntax-rules ()
    [(_ type (name field ...) ...)
     (begin
       (define-constructors type ((name field ...) ...)))]))

(define-syntax define-constructors
  (syntax-rules ()
    [(define-constructors type ((name field ...) ...))
     (define-constructors type ((name field ...) ...) (name ...))]
    [(define-constructors type ((name field ...) ...) names)
     (begin
       (define-constructor type (name field ...) names)
       ...)]))

(define-syntax define-constructor
  (syntax-rules ()
    [(_ type (name field ...) names)
     (define (name field ...)
       (cons 'type
             (lambda names
               (name field ...))))]))

(define-syntax cases
  (syntax-rules ()
    [(_ type x [(name field ...) exp]
          ...)
     ((cdr x) (lambda (field ...) exp)
              ...)]))

(define (type-of x) (car x))

;---------------------------------------

; class Interpreter Exp a where
;     interpret : Exp a -> Number

(define-class Interpreter interpret)

(define-type base-expression (base))

; instance Interpreter base-expression where
;     interpret (base) = error "No semantics"

(define base-interpreter
  (make-Interpreter
     (lambda (exp)
       (cases base-expression exp
         ((base) (error "No Semantics"))))))

; type abel-expression a = base base-expression
;                        | num Number
;                        | plus a a          

(define-type abel-expression
  (base base-exp)
  (num val)
  (plus lhs rhs))

; instance (Promise (Interpreter a)) => Interpreter abel-expression a where
;    interpret (base base-exp) = interpret base-exp
;    interpret (num val)       = val
;    interpret (plus lhs rhs)  = + (interpret lhs) (interpret rhs)

(define (abel-interpreter inta)
  (make-Interpreter
   (lambda (exp)
     (with-instance ((Interpreter (force inta)))
       (cases abel-expression exp
         ((base base-exp)
          (with-instance ((Interpreter base-interpreter))
            (interpret base-exp)))
         ((num val) val)
         ((plus lhs rhs)
          (+ (interpret lhs) (interpret rhs))))))))

(define-type ring-expression
  (abel abel-exp)
  (mult lhs rhs))

; Instance (Promise (Interpreter a)) => Interpreter ring-expression a where
;    ...

(define (ring-interpreter inta)
  (make-Interpreter
   (lambda (exp)
     (with-instance ((Interpreter (force inta)))
       (cases abel-expression exp
         ((abel abel-exp)
          (with-instance ((Interpreter (abel-interpreter inta)))
            (interpret abel-exp)))
         ((mult lhs rhs)
          (* (interpret lhs) (interpret rhs))))))))

; Tie the knot:                          ;
; type final = ring-expression final
;  ::::: implies, by the above, that
; instance Interpreter final  

(define final-interpreter
  (ring-interpreter (delay final-interpreter)))

;-----------------------------------------
; Test:

(print
(with-instance ((Interpreter final-interpreter))
      (assert (= (interpret
		  (mult (abel (num 2)) (abel (num 2))))
		 4)
	      ))
)