; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Last update: Jun 19, 2011
;
; Copyright (c) 2011, 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.
; 

;In this module, we'll tuples, a container structure like lists or
;vectors, but with one important difference: The data in a tuple are
;encapsulated. That means, there are no state-changing routines like
;list-set! and vector-set! so that the encapsulated data can not be
;changed, unless they are stored in a single (or a box).

;A single is a tuple storing one item only, but this item can be changed
;without changing the single itself. This way state-changing is
;resticted to the absolute necessity.

;There are three other special tuples, empty, couples and triples, which
;store what their names suggest. Note that with couples and empty you
;can do the same things as with lists (but without state changing, of
;course), albeit the access routines are named differently: couple-left
;and couple-right.

(require 'contracts)

(module tuples ;*
  (tuples tuple tuple? tuple-of? tuple-length tuple-ref tuple-find
   tuple-map tuple-append list->tuple tuple->list tuple-for-each
   empty empty? single single? single-state single-state!
   couple couple? couple-left couple-right triple triple? triple-left
   triple-middle triple-right tuple-left tuple-right tuple-copy)
  
(import scheme
        contracts
        (only chicken unless condition-case case-lambda sub1 add1)
        (only data-structures list-of?))

;; initialize documentation (aliases are inserted by hand)
(doclist '())

;;; general n-tuples

;;; constructors
(define-with-contract (tuple . args)
  "tuple constructor"
  (domain: (true? args))
  (range: (tuple? result)
          "a routine which chooses from a selector")
  (lambda (sel)
    (apply sel (cons 'tuple (cons (length args) args)))))

(define-with-contract (list->tuple lst)
  "transforms a list into a tuple"
  (domain: (list? lst))
  (range: (tuple? result))
  (apply tuple lst))

(define-with-contract (tuple-map fn tup)
  "constructs a new tuple by mapping each item of tup with function fn"
  (domain: (tuple? tup)
           (procedure? fn)
           "a one parameter function")
  (range: (tuple? result))
  (let loop ((n (tuple-length tup)) (acc '()))
    (if (zero? n)
      (apply tuple acc)
      (loop (sub1 n) (cons (fn (tuple-ref tup (sub1 n))) acc)))))

(define-with-contract (tuple-append . tups)
  "constructs a new tuple by concatenating several others"
  (domain: ((list-of? tuple?) tups))
  (range: (tuple? result))
  (lambda (sel)
    (apply sel (cons 'tuple
                     (cons (apply + (map tuple-length tups))
                           (apply append (map tuple->list tups)))))))

(define-with-contract (tuple-copy tup . range)
  "constructing a subtuple with tup data from range"
  (domain: (tuple? tup)
           (<= (length range) 2)
           ((list-of? cardinal?) range)
           (apply <= (append range (list (tuple-length tup)))))
  (range: (tuple? result))
  (let (
    (from (if (null? range)
            0
            (car range)))
    (upto (if (< (length range) 2)
            (tuple-length tup)
            (cadr range)))
    )
    (let loop ((n upto) (acc '()))
      (if (= from n)
        (apply tuple acc)
        (loop (sub1 n) (cons (tuple-ref tup (sub1 n)) acc))))))

;;; predicates
(define-with-contract (tuple? xpr)
  "checks if xpr evaluates to a tuple"
  (and (procedure? xpr)
       (condition-case (eq? 'tuple (xpr (project 0)))
         ((exn) #f))))

(define-with-contract (tuple-of? ok?)
  "checks, if each tuple item satisfies predicate ok?"
  (domain: (procedure? ok?)
           "ok? is a one parameter predicate")
  (range: (procedure? result)
          "result is a one parameter predicate")
  (lambda (x)
    (and (tuple? x)
         (let helper ((n (tuple-length x)))
           (if (zero? n)
             #t
             (and (ok? (tuple-ref x (sub1 n))) (helper (sub1 n))))))))

;;; accessors
(define-with-contract (tuple-length tup)
  "returns the number of tuple items"
  (domain: (tuple? tup))
  (range: (cardinal? result))
  (tup (project 1)))

(define-with-contract (tuple-ref tup n)
  "returns the n'th item of tup, counting from zero"
  (domain: (tuple? tup) (cardinal? n) (< n (tuple-length tup)))
  (tup (project (+ n 2))))

(define-with-contract (tuple-left tup)
  "returns the leftmost item of tup"
  (domain: (tuple? tup) (positive? (tuple-length tup)))
  (tup (project 2)))

(define-with-contract (tuple-right tup)
  "returns the rightmost item of tup"
  (domain: (tuple? tup) (>= (tuple-length tup) 2))
  (tup (project (+ (tuple-length tup) 1))))

(define-with-contract (tuple-find tup item compare?)
  "checks by comparing with compare? if item is contained in tup"
  (domain: (tuple? tup)
           (procedure? compare?)
           "a two parameter predicate")
  (range: (or (not result)
              (and (cardinal? result) (< result (tuple-length tup)))))
  (let ((len (tuple-length tup)))
    (if (zero? len)
      #f
      (let loop ((result 0))
        (cond
          ((= result len) #f)
          ((compare? item (tuple-ref tup result)) result)
          (else (loop (add1 result))))))))

(define-with-contract (tuple-for-each proc tup)
  "apply a one parameter procedure to each item of tup"
  (domain: (tuple? tup)
           (procedure? proc)
           "a one parameter procedure")
  (let ((len (tuple-length tup)))
    (let loop ((n 0))
      (unless (= n len)
        (proc (tuple-ref tup n))
        (loop (add1 n))))))

(define-with-contract (tuple->list tup)
  "transforms a tuple into a list"
  (domain: (tuple? tup))
  (range: (list? result))
  (let loop ((n (tuple-length tup)) (acc '()))
  (if (zero? n)
    acc
    (loop (sub1 n) (cons (tuple-ref tup (sub1 n)) acc)))))

;;; predicate
(define-with-contract (single? xpr)
  "check, if xpr evaluates to a single"
  (and (procedure? xpr)
       (condition-case (eq? 'single (xpr (project 0)))
         ((exn) #f))))

;;; singles are tuples which store exactly one item. But without being
;;; able to modify this item, singles were useless. So we give an
;;; independent definition of its constructor.
(define-with-contract (single xpr)
  "package xpr into a box so that it can be modified"
  (domain: (true? xpr))
  (range: (single? result))
  (lambda (sel)
    (sel 'single xpr (lambda (new) (set! xpr new)))))

;;; query
(define-with-contract (single-state sg)
  "returns the state of the single object sg"
  (domain: (single? sg))
  (range: (true? result))
  (sg (project 1)))

;;; command
(define-with-contract (single-state! sg arg)
  "replaces state of sg with arg"
  (domain: (single? sg) (true? arg))
  (effect: (state (single-state sg) arg))
  ((sg (project 2)) arg))

;;; couples are tuples which store two items
(define-with-contract (couple? x)
  "tests for a tuple storing two items"
  (and (tuple? x) (= (tuple-length x) 2)))

(define-with-contract (couple x y)
  "constructor for a tuple storing two items"
  (tuple x y))

(define-with-contract (couple-left tup)
  "returns the left item of a couple"
  (tuple-ref tup 0))

(define-with-contract (couple-right tup)
  "returns the right item of a couple"
  (tuple-ref tup 1))

;;; couples are tuples which store three items
(define-with-contract (triple? x)
  "tests for a tuple storing two items"
  (and (tuple? x) (= (tuple-length x) 3)))

(define-with-contract (triple x y z)
  "constructor for a tuple storing two items"
  (tuple x y z))

(define-with-contract (triple-left tup)
  "returns the left item of a triple"
  (tuple-ref tup 0))

(define-with-contract (triple-middle tup)
  "returns the middle item of a triple"
  (tuple-ref tup 1))

(define-with-contract (triple-right tup)
  "returns the right item of a triple"
  (tuple-ref tup 2))

;;; empty is the tuple which stores nothing
(define-with-contract (empty? x)
  "tests for an empty tuple"
  (and (tuple? x) (= (tuple-length x) 0)))

(define-with-contract (empty)
  "constructor for an empty tuple"
  (tuple))

;;; internal helpers
(define (cardinal? n)
  (and (integer? n) (exact? n) (not (negative? n))))

(define (true? x) #t)

(define (project n)
  (lambda args
    (list-ref args n)))

;;; documentation
(define tuples (doclist->dispatcher (doclist)))

) ; module tuples