; Copyright (c) 2012-2013, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; 

; Author: Juergen Lorenz
;         ju (at) jugilo (dot) de
;
; Last update: Mar 13, 2013
;
;In this module, we'll implement tuples, triples, couples and singles.
;
;A tuple is a container structure like vectors, but with one important
;difference: The data in a tuple are encapsulated. That means, there are
;no state-changing routines like vector-set! so that the encapsulated
;data can not be changed. The same applies to triples and couples, which
;are specialized tuples of length 3 and 2 respectively.
;
;Singles are different: they store one item only, but that item is
;mutable. Hence one can store an item of type single in a tuple, and
;that item is then mutable.  This way state-changing is resticted to the
;absolute necessity.

(require-library dbc)

(module %tuples
  (tuple tuple? tuple-length tuple-ref tuple-find tuple-cons-left
   tuple-cons-right tuple-map tuple-append list->tuple tuple->list
   tuple-for-each tuple->vector vector->tuple tuple-of?
   tuple-from-upto tuple-eql? tuple-reverse tuple-split
   triple triple? triple-left triple-middle triple-right triple-eql?
   triple->tuple
   couple couple? couple-left couple-right couple-eql?
   couple->tuple
   single-eql? single single?  single-ref single-set!)

(import scheme
        (only chicken unless condition-case define-record-type
              define-record-printer define-reader-ctor
              error gensym open-output-string get-output-string))

(define sentinel (gensym 'sentinel))

(define-record-type tuple
  (make-tuple selector)
  tuple?
  (selector tuple-selector))

(define (tuple . args)
  (make-tuple (lambda (n) (vector-ref (apply vector args) n))))

(define (tuple-ref tup n)
  ((tuple-selector tup) n))

(define (tuple-length tup)
  (let loop ((n 0))
    (if (eq? (condition-case (tuple-ref tup n)
               ((exn) sentinel))
             sentinel)
      n
      (loop (+ n 1)))))

(define (tuple-cons-left arg tup)
  (apply tuple arg (tuple->list tup)))

(define (tuple-cons-right arg tup)
  (apply tuple (append (tuple->list tup) (list arg))))

(define (tuple-reverse tup)
  (apply tuple (reverse (tuple->list tup))))

(define (tuple-of? ok?)
  (lambda (x)
    (and (tuple? x)
         (let helper ((n (tuple-length x)))
           (if (zero? n)
             #t
             (and (ok? (tuple-ref x (- n 1))) (helper (- n 1))))))))

(define (tuple-map fn tup . tups)
  (let loop ((n (tuple-length tup)) (acc '()))
    (if (zero? n)
      (apply tuple acc)
      (loop (- n 1)
            (cons (apply fn (tuple-ref tup (- n 1))
                         (map (lambda (tup) (tuple-ref tup (- n 1)))
                              tups))
                  acc)))))

(define (tuple-for-each proc tup . tups)
  (let loop ((n 0))
    (unless (= n (tuple-length tup))
      (apply proc (tuple-ref tup n)
             (map (lambda (tup) (tuple-ref tup n)) tups))
      (loop (+ n 1)))))

(define (tuple-eql? eql? tup0 tup1)
  (and (= (tuple-length tup0) (tuple-length tup1))
       (not (tuple-find not (tuple-map eql? tup0 tup1)))))

(define (tuple-append . tups)
  (apply tuple (apply append (map tuple->list tups))))

(define (tuple->list tup)
  (let loop ((n (tuple-length tup)) (acc '()))
    (if (zero? n)
      acc
      (loop (- n 1) (cons (tuple-ref tup (- n 1)) acc)))))

(define (list->tuple lst)
  (apply tuple lst))

(define (tuple->vector tup)
  (let ((result (make-vector (tuple-length tup))))
    (tuple-for-each
      (lambda (n) (vector-set! result n (tuple-ref tup n)))
      tup)
    result))

(define (vector->tuple vec)
  (make-tuple (lambda (n) (vector-ref vec n))))

(define (tuple-from-upto tup from upto)
  (let loop ((n upto) (acc '()))
    (if (= from n)
      (apply tuple acc)
      (loop (- n 1) (cons (tuple-ref tup (- n 1)) acc)))))

(define (tuple-split tup at)
  (let loop ((n (- (tuple-length tup) 1)) (head '()) (tail '()))
    (if (< n 0)
      (values (apply tuple head) (apply tuple tail))
      (if (>= n at)
        (loop (- n 1) head (cons (tuple-ref tup n) tail))
        (loop (- n 1) (cons (tuple-ref tup n) head) tail)))))

(define (tuple-find ok? tup)
  (let ((len (tuple-length tup)))
    (if (zero? len)
      #f
      (let loop ((result 0))
        (cond
          ((= result len) #f)
          ((ok? (tuple-ref tup result)) result)
          (else (loop (+ result 1))))))))

(define-record-printer (tuple tup out)
  (display "#,(tuple" out)
  (tuple-for-each
    (lambda (x)
      (display " " out)
      (write x out))
    tup)
  (display ")" out)
  (newline out))

(define-reader-ctor 'tuple tuple)

;;; triples as three-tuples with its own type
(define-record-type triple
  (make-triple selector)
  triple?
  (selector triple-selector))

(define (triple x y z)
  (make-triple (lambda (n)
                 (vector-ref (vector x y z) n))))

(define (triple-left trp)
  ((triple-selector trp) 0))

(define (triple-middle trp)
  ((triple-selector trp) 1))

(define (triple-right trp)
  ((triple-selector trp) 2))

(define (triple-eql? eql? trp0 trp1)
  (and (eql? (triple-left trp0) (triple-left trp1))
       (eql? (triple-middle trp0) (triple-middle trp1))
       (eql? (triple-right trp0) (triple-right trp1))))

(define (triple->tuple trp)
  (make-tuple (triple-selector trp)))

(define-record-printer (triple trp out)    
  (display "#,(triple " out)
  (write (triple-left trp) out)
  (display " " out)
  (write (triple-middle trp) out)
  (display " " out)
  (write (triple-right trp) out)
  (display ")" out)
  (newline out))

(define-reader-ctor 'triple triple)

;;; couples as two-tuples with its own type
(define-record-type couple
  (make-couple selector)
  couple?
  (selector couple-selector))

(define (couple x y)
  (make-couple (lambda (n)
                 (vector-ref (vector x y) n))))

(define (couple-left cpl)
  ((couple-selector cpl) 0))

(define (couple-right cpl)
  ((couple-selector cpl) 1))

(define (couple-eql? eql? cpl0 cpl1)
  (and (eql? (couple-left cpl0) (couple-left cpl1))
       (eql? (couple-right cpl0) (couple-right cpl1))))

(define (couple->tuple trp)
  (make-tuple (couple-selector trp)))

(define-record-printer (couple cpl out)
  (display "#,(couple " out)
  (write (couple-left cpl) out)
  (display " " out)
  (write (couple-right cpl) out)
  (display ")" out)
  (newline out))

(define-reader-ctor 'couple couple)

;;; singles as mutable one-tuples with its own type
(define-record-type single
  (make-single selector)
  single?
  (selector single-selector))

(define (single x)
  (make-single (lambda (n)
                 (vector-ref (vector x (lambda (new) (set! x new)))
                             n))))
(define (single-ref sgl)
  ((single-selector sgl) 0))

(define (single-set! sgl new)
  (((single-selector sgl) 1) new))

(define (single-eql? eql? sgl0 sgl1)
  (eql? (single-ref sgl0) (single-ref sgl1)))

(define-record-printer (single sgl out)
  (display "#,(single " out)
  (write (single-ref sgl) out)
  (display ")" out)
  (newline out))

(define-reader-ctor 'single single)

) ; module %tuples


(module tuples
  (tuples tuple tuple? tuple-length tuple-ref tuple-find tuple-copy
   tuple-map tuple-append list->tuple tuple->list tuple-for-each
   tuple-empty? tuple->vector vector->tuple tuple-of? tuple-from-upto
   tuple-left tuple-right tuple-butleft tuple-butright tuple-head
   tuple-tail tuple-eql? tuple-equal? tuple-eqv?  tuple-eq? tuple-split
   tuple-cons-left tuple-cons-right tuple-reverse)

(import scheme
        dbc
        (prefix %tuples %)
        (only chicken unless condition-case case-lambda define-inline
              let-optionals
              open-output-string get-output-string)
        (only data-structures list-of?))

(define-inline (cardinal? n)
  (and (integer? n) (exact? n) (not (negative? n))))

(init-dbc)

;;; predicates
(define-with-contract tuple?
  (contract (result)
    ((_ xpr) #t (boolean? result)))
  %tuple?)

(define-with-contract tuple-of?
  (contract (result)
    ((_ ok?) (procedure? ok?) (procedure? result)))
  %tuple-of?)

(define-with-contract tuple-empty?
  (contract (result)
    ((_ xpr) #t (boolean? result)))
  (lambda (xpr) (and (%tuple? xpr) (zero? (%tuple-length xpr)))))

;;; constructors
(define-with-contract tuple
  (contract (result)
    ((_ . args) #t (%tuple? result)))
  %tuple)

(define-with-contract tuple-cons-left
  (contract (result)
    ((_ arg tup)
     (%tuple? tup)
     (and (%tuple result)
          (= (%tuple-length result)
             (+ (%tuple-length tup) 1)))))
  %tuple-cons-left)

(define-with-contract tuple-cons-right
  (contract (result)
    ((_ arg tup)
     (%tuple? tup)
     (and (%tuple result)
          (= (%tuple-length result)
             (+ (%tuple-length tup) 1)))))
  %tuple-cons-right)

(define-with-contract tuple-reverse
  (contract (result)
    ((_ tup)
     (%tuple? tup)
     (and (%tuple result)
          (= (%tuple-length result)
             (%tuple-length tup)))))
  %tuple-reverse)

(define-with-contract list->tuple
  (contract (result)
    ((_ lst)
     (list? lst)
     (and (%tuple? result)
          (= (length lst) (%tuple-length result)))))
  %list->tuple)

(define-with-contract vector->tuple
  (contract (result)
    ((_ vec)
     (vector? vec)
     (and (%tuple? result)
          (= (%tuple-length result) (vector-length vec)))))
  %vector->tuple)

(define-with-contract tuple-map
  (contract (result)
    ((_ fn tup . tups)
     (and (procedure? fn) (%tuple? tup) ((list-of? %tuple?) tups)
          (apply = (%tuple-length tup) (map %tuple-length tups)))
     (and (%tuple? result)
          (= (%tuple-length tup) (%tuple-length result)))))
  %tuple-map)

(define-with-contract tuple-append
  (contract (result)
    ((_ . tups)
     ((list-of? %tuple?) tups)
     (and (%tuple? result)
          (= (tuple-length result)
             (apply + (map tuple-length tups))))))
  %tuple-append)

(define-with-contract tuple-from-upto
  (contract (result)
    ((_ tup . interval)
       (and (%tuple tup)
            ((list-of? (lambda (x)
                         (and (cardinal? x)
                              (<= x (%tuple-length tup)))))
                       interval)
            (<= (length interval) 2)
            (apply <= 0 interval))
       (and (%tuple? result)
            (= (%tuple-length result)
               (case (length interval)
                 ((0) (%tuple-length tup))
                 ((1) (- (%tuple-length tup) (car interval)))
                 ((2) (- (cadr interval) (car interval))))))))
    (lambda (tup . interval)
      (let-optionals interval ((from 0) (upto (%tuple-length tup)))
        (%tuple-from-upto tup from upto))))

(define-with-contract tuple-split
  (contract (head tail)
    ((_ tup at)
     (and (%tuple? tup)
          (cardinal? at) (< at (%tuple-length tup)))
     (and (%tuple? head) (%tuple? tail)
          (%tuple-eql? equal? tup (%tuple-append head tail)))))
  %tuple-split)

(define-with-contract tuple-copy
  (contract (result)
    ((_ tup) (%tuple tup) (%tuple result)))
  (lambda (tup) (%tuple-from-upto tup 0 (%tuple-length tup))))

;;; accessors
(define-with-contract tuple-length
  (contract (result)
    ((_ tup) (%tuple? tup) (cardinal? result)))
  %tuple-length)

(define-with-contract tuple-ref
  (contract (result)
    ((_ tup n)
     (and (%tuple? tup) (cardinal? n) (< -1 n (%tuple-length tup)))
     "tup's nth item"))
  %tuple-ref)

(define-with-contract tuple-left
  (contract (result)
    ((_ tup)
     (and (%tuple? tup) (positive? (%tuple-length tup)))
     "tup's leftmost item"))
  (lambda (tup) (%tuple-ref tup 0)))
  ;%tuple-left)

(define-with-contract tuple-right
  (contract (result)
    ((_ tup)
     (and (%tuple? tup) (positive? (%tuple-length tup)))
     "tup's rightmost item"))
  (lambda (tup) (%tuple-ref tup (- (%tuple-length tup) 1))))
  ;%tuple-right)

(define-with-contract tuple-butleft
  (contract (result)
    ((_ tup)
     (and (%tuple? tup) (positive? (%tuple-length tup)))
     (and (%tuple result)
          (= (%tuple-length result)
             (- (%tuple-length tup) 1)))))
  (lambda (tup) (%tuple-from-upto tup 1 (%tuple-length tup))))

(define-with-contract tuple-butright
  (contract (result)
    ((_ tup)
     (and (%tuple? tup) (positive? (%tuple-length tup)))
     (and (%tuple result)
          (= (%tuple-length result)
             (- (%tuple-length tup) 1)))))
  (lambda (tup) (%tuple-from-upto tup 0 (- (%tuple-length tup) 1))))

(define-with-contract tuple-head
  (contract (result)
    ((_ tup n)
     (and (%tuple? tup) (<= n (%tuple-length tup)))
     (and (%tuple result)
          (= (%tuple-length result) n))))
  (lambda (tup n) (%tuple-from-upto tup 0 n)))

(define-with-contract tuple-tail
  (contract (result)
    ((_ tup n)
     (and (%tuple? tup) (<= n (%tuple-length tup)))
     (and (%tuple result)
          (= (%tuple-length result)
             (- (%tuple-length tup) n)))))
  (lambda (tup n) (%tuple-from-upto tup n (%tuple-length tup))))
  
(define-with-contract tuple-find
  (contract (result)
    ((_ ok? tup)
     (and (procedure? ok?) (%tuple? tup))
     (or (not result)
         (and (cardinal? result) (< result (%tuple-length tup))
              "index of found item"))))
  %tuple-find)

(define-with-contract tuple->list
  (contract (result)
    ((_ tup) (%tuple? tup) (list? result)))
  %tuple->list)
  
(define-with-contract tuple->vector
  (contract (result)
    ((_ tup) (%tuple? tup) (vector? result)))
  %tuple->vector)
  
(define-with-contract tuple-eql?
  (contract (result)
    ((_ eql? tup0 tup1)
     (and (procedure? eql?) (%tuple? tup0) (%tuple? tup1))
     (boolean? result)))
  %tuple-eql?)

(define-with-contract tuple-equal?
  (contract (result)
    ((_ tup0 tup1)
     (and (%tuple? tup0) (%tuple? tup1))
     (boolean? result)))
  (lambda (tup0 tup1) (%tuple-eql? equal? tup0 tup1)))

(define-with-contract tuple-eqv?
  (contract (result)
    ((_ tup0 tup1)
     (and (%tuple? tup0) (%tuple? tup1))
     (boolean? result)))
  (lambda (tup0 tup1) (%tuple-eql? eqv? tup0 tup1)))

(define-with-contract tuple-eq?
  (contract (result)
    ((_ tup0 tup1)
     (and (%tuple? tup0) (%tuple? tup1))
     (boolean? result)))
  (lambda (tup0 tup1) (%tuple-eql? eq? tup0 tup1)))

(define-with-contract tuple-for-each
  (command-contract ((old new (lambda (proc tup . tups) #t)))
    ((_ proc tup . tups)
     (and (procedure? proc) (%tuple tup) ((list-of? %tuple?) tups)
          (apply = (%tuple-length tup) (map %tuple-length tups)))
     "proc applied to each item")) ; no checks
  %tuple-for-each)

(exit-dbc-with tuples)

) ; module tuples

;;;; triples are tuples which store three items
(module triples
  (triples triple triple? triple-left triple-middle triple-right
           triple-eql? triple-equal? triple-eqv? triple-eq?
           triple->tuple)

(import scheme dbc
        (prefix %tuples %))

(init-dbc)

(define-with-contract triple?
  (contract (result)
    ((_ x)
     #t
     (boolean? result)))
  %triple?)

(define-with-contract triple
  (contract (result)
    ((_ x y z)
     #t
     (%triple? result)))
  %triple)

(define-with-contract triple-left
  (contract (result)
    ((_ trp)
     (%triple? trp)
     "leftmost item"))
  %triple-left)

(define-with-contract triple-middle
  (contract (result)
    ((_ trp)
     (%triple? trp)
     "item in the middle"))
  %triple-middle)

(define-with-contract triple-right
  (contract (result)
    ((_ trp)
     (%triple? trp)
     "rightmost item"))
  %triple-right)

(define-with-contract triple-eql?
  (contract (result)
    ((_ eql? trp0 trp1)
     (and (procedure? eql?) (%triple? trp0) (%triple? trp1))
     (boolean? result)))
  %triple-eql?)

(define-with-contract triple-equal?
  (contract (result)
    ((_ trp0 trp1)
     (and (%triple? trp0) (%triple? trp1))
     (boolean? result)))
  (lambda (trp0 trp1) (%triple-eql? equal? trp0 trp1)))

(define-with-contract triple-eqv?
  (contract (result)
    ((_ trp0 trp1)
     (and (%triple? trp0) (%triple? trp1))
     (boolean? result)))
  (lambda (trp0 trp1) (%triple-eql? eqv? trp0 trp1)))

(define-with-contract triple-eq?
  (contract (result)
    ((_ trp0 trp1)
     (and (%triple? trp0) (%triple? trp1))
     (boolean? result)))
  (lambda (trp0 trp1) (%triple-eql? eq? trp0 trp1)))

(define-with-contract triple->tuple
  (contract (result)
    ((_ trp)
     (%triple? trp)
     (and (%tuple? result) (= (%tuple-length result) 3))))
  %triple->tuple)

(exit-dbc-with triples)

) ; triples

;;;; couples are tuples which store two items
(module couples
  (couples couple couple? couple-left couple-right couple-eql?
           couple-equal? couple-eqv? couple-eq? couple->tuple)

(import scheme dbc
        (prefix %tuples %))

(init-dbc)

(define-with-contract couple?
  (contract (result)
    ((_ x)
     #t
     (boolean? result)))
  %couple?)

(define-with-contract couple
  (contract (result)
    ((_ x y)
     #t
     (%couple? result)))
  %couple)

(define-with-contract couple-left
  (contract (result)
    ((_ cpl)
     (%couple? cpl)
     "leftmost item"))
  %couple-left)

(define-with-contract couple-right
  (contract (result)
    ((_ cpl)
     (%couple? cpl)
     "rightmost item"))
  %couple-right)

(define-with-contract couple-eql?
  (contract (result)
    ((_ eql? cpl0 cpl1)
     (and (procedure? eql?) (%couple? cpl0) (%couple? cpl1))
     (boolean? result)))
  %couple-eql?)

(define-with-contract couple-equal?
  (contract (result)
    ((_ cpl0 cpl1)
     (and (%couple? cpl0) (%couple? cpl1))
     (boolean? result)))
  (lambda (cpl0 cpl1) (%couple-eql? equal? cpl0 cpl1)))

(define-with-contract couple-eqv?
  (contract (result)
    ((_ cpl0 cpl1)
     (and (%couple? cpl0) (%couple? cpl1))
     (boolean? result)))
  (lambda (cpl0 cpl1) (%couple-eql? eqv? cpl0 cpl1)))

(define-with-contract couple-eq?
  (contract (result)
    ((_ cpl0 cpl1)
     (and (%couple? cpl0) (%couple? cpl1))
     (boolean? result)))
  (lambda (cpl0 cpl1) (%couple-eql? eq? cpl0 cpl1)))

(define-with-contract couple->tuple
  (contract (result)
    ((_ cpl)
     (%couple? cpl)
     (and (%tuple? result) (= (%tuple-length result) 2))))
  %couple->tuple)

(exit-dbc-with couples)

) ; couples

;;;; singles are mutable one-tuples
(module singles
  (singles single single? single-ref single-set! single-eql?
           single-equal? single-eqv? single-eq?)

(import scheme dbc
        (prefix %tuples %))

(init-dbc)

;;; constructor
(define-with-contract single
  (contract (result)
    ((_ x) #t (%single? result)))
  %single)

;;; predicate
(define-with-contract single?
  (contract (result)
    ((_ x) #t (boolean? result)))
  %single?)

;;; query
(define-with-contract single-ref
  (contract (result)
    ((_ sg) (%single? sg) "sg's stored item"))
  %single-ref)

;;; command
(define-with-contract single-set!
  (command-contract ((old new (lambda (sg x) (%single-ref sg))))
    ((_ sg x) (%single? sg) (equal? new x)))
  %single-set!)

(define-with-contract single-eql?
  (contract (result)
    ((_ eql? sgl0 sgl1)
     (and (procedure? eql?) (%single? sgl0) (%single? sgl1))
     (boolean? result)))
  %single-eql?)

(define-with-contract single-equal?
  (contract (result)
    ((_ sgl0 sgl1)
     (and (%single? sgl0) (%single? sgl1))
     (boolean? result)))
  (lambda (sgl0 sgl1) (%single-eql? equal? sgl0 sgl1)))

(define-with-contract single-eqv?
  (contract (result)
    ((_ sgl0 sgl1)
     (and (%single? sgl0) (%single? sgl1))
     (boolean? result)))
  (lambda (sgl0 sgl1) (%single-eql? eqv? sgl0 sgl1)))

(define-with-contract single-eq?
  (contract (result)
    ((_ sgl0 sgl1)
     (and (%single? sgl0) (%single? sgl1))
     (boolean? result)))
  (lambda (sgl0 sgl1) (%single-eql? eq? sgl0 sgl1)))

(exit-dbc-with singles)

) ; singles