#|[
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 gensym))

(define sentinel (gensym 'sentinel))

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

(define (tuple . args)
  (let ((vec (apply vector args)))
    (make-tuple (lambda (n) (vector-ref vec 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)
  (let ((vec (vector x y z)))
    (make-triple (lambda (n)
                   (vector-ref vec 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)
  (let ((vec (vector x y)))
    (make-couple (lambda (n)
                   (vector-ref vec 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 (op)
                 (op x (lambda (new) (set! x new))))))

(define (single-ref sgl)
  ((single-selector sgl) (lambda (ref set) ref)))

(define (single-set! sgl new)
  (((single-selector sgl) (lambda (ref set) set)) 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