; Copyright (c) 2012, 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 07, 2012
;
;In this module, we'll implement tuples, 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, 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-ref single-set!
   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 define-inline
          open-output-string get-output-string)
        (only data-structures list-of?))

;;; implementation and helpers
;;; must appear before interface, because some routines are inlined

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

(define-inline (true? x) #t)

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

(define-inline (%tuple-length tup)
  (tup (project 1)))

(define-inline (%tuple-ref tup n)
  (tup (project (+ n 2))))

(define-inline (%tuple-left tup)
  (tup (project 2)))

(define-inline (%tuple-right tup)
  (tup (project (+ (%tuple-length tup) 1))))

(define-inline (%tuple-state sg)
  (sg (project 1)))

(define-inline (%tuple-state! sg arg)
  ((sg (project 2)) arg))

(define (%tuple? xpr)
  (and (procedure? xpr)
       (condition-case (eq? 'tuple (xpr (project 0)))
         ((exn) #f))))

(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 . args)
  (lambda (sel)
    (apply sel (cons 'tuple (cons (length args) args)))))

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

(define (%tuple-append . tups)
  (lambda (sel)
    (apply sel (cons 'tuple
                     (cons (apply + (map %tuple-length tups))
                           (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 (%tuple-copy tup . intervall)
  (let (
    (from (if (null? intervall)
            0
            (car intervall)))
    (upto (if (< (length intervall) 2)
            (%tuple-length tup)
            (cadr intervall)))
    )
    (let loop ((n upto) (acc '()))
      (if (= from n)
        (apply %tuple acc)
        (loop (- n 1) (cons (%tuple-ref tup (- n 1)) acc))))))

(define (%tuple-find tup item compare?)
  (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 (+ result 1))))))))

(define (%tuple-for-each proc tup)
  (let ((len (%tuple-length tup)))
    (let loop ((n 0))
      (unless (= n len)
        (proc (%tuple-ref tup n))
        (loop (+ n 1))))))

(define (%single? xpr)
  (and (procedure? xpr)
       (condition-case (eq? 'single (xpr (project 0)))
         ((exn) #f))))

(define (%single xpr)
  (lambda (sel)
    (sel 'single xpr (lambda (new) (set! xpr new)))))

;; initialize documentation
(doclist '())

;;; iterface

;;; general n-tuples

;;; predicates
(define-with-contract (tuple? xpr)
  "checks if xpr evaluates to a tuple"
  (%tuple? xpr))

(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")
  (%tuple-of? ok?))

;;; constructors
(define-with-contract (tuple . args)
  "tuple constructor"
  (domain (true? args))
  (range (%tuple? result))
  (apply %tuple 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))
  (%tuple-map fn tup))

(define-with-contract (tuple-append . tups)
  "constructs a new tuple by concatenating several others"
  (domain ((list-of? tuple?) tups))
  (range (%tuple? result))
  (apply %tuple-append tups))

(define-with-contract (tuple-copy tup . interval)
  "constructing a subtuple with tup data from interval"
  (domain (%tuple? tup)
           (<= (length interval) 2)
           ((list-of? cardinal?) interval)
           (apply <= (append interval (list (%tuple-length tup)))))
  (range (%tuple? result))
  (apply %tuple-copy tup interval))

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

(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)))
  (%tuple-ref tup n))

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

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

(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)))))
  (%tuple-find tup item compare?))

(define-with-contract (tuple->list tup)
  "transforms a tuple into a list"
  (domain (%tuple? tup))
  (range (list? result))
  (%tuple->list tup))

(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")
  (%tuple-for-each proc tup))

;;; 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))

;;; 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)
  "check, if xpr evaluates to a single"
  (%single? xpr))

(define-with-contract (single xpr)
  "package xpr into a box so that it can be modified"
  (domain (true? xpr))
  (range (%single? result))
  (%single xpr))

;;; query
(define-with-contract (single-ref sg)
  "returns the state of the single object sg"
  (domain (%single? sg))
  (%tuple-state sg))

;;; command
(define-with-contract (single-set! sg arg)
  "replaces state of sg with arg"
  (domain (%single? sg) (true? arg))
  (effect (state (%tuple-state sg) arg))
  (%tuple-state! sg 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 1 2))

(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))

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

) ; module tuples