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

; Author: Juergen Lorenz
;         ju (at) jugilo (dot) de
;
; Last update: Oct 05, 2011
;
;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-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 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 (%length tup)
  (tup (project 1)))

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

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

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

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

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

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

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

(define (%tuple . args)
  (lambda (sel)
    (apply sel (cons 'tuple (cons (length args) args)))))

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

(define (%tuple-append . tups)
  (lambda (sel)
    (apply sel (cons 'tuple
                     (cons (apply + (map %length tups))
                           (apply append (map %>list tups)))))))

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

(define (%copy tup . intervall)
  (let (
    (from (if (null? intervall)
            0
            (car intervall)))
    (upto (if (< (length intervall) 2)
            (%length tup)
            (cadr intervall)))
    )
    (let loop ((n upto) (acc '()))
      (if (= from n)
        (apply %tuple acc)
        (loop (- n 1) (cons (%ref tup (- n 1)) acc))))))

(define (%find tup item compare?)
  (let ((len (%length tup)))
    (if (zero? len)
      #f
      (let loop ((result 0))
        (cond
          ((= result len) #f)
          ((compare? item (%ref tup result)) result)
          (else (loop (+ result 1))))))))

(define (%for-each proc tup)
  (let ((len (%length tup)))
    (let loop ((n 0))
      (unless (= n len)
        (proc (%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")
  (%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))
  (%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 %copy tup interval))

;;; accessors
(define-with-contract (tuple-length tup)
  "returns the number of tuple items"
  (domain (tuple? tup))
  (range (cardinal? result))
  (%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)))
  (%ref tup n))

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

(define-with-contract (tuple-right tup)
  "returns the rightmost item of tup"
  (domain (tuple? tup) (>= (tuple-length tup) 2))
  (%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)))))
  (%find tup item compare?))

(define-with-contract (tuple->list tup)
  "transforms a tuple into a list"
  (domain (tuple? tup))
  (range (list? result))
  (%>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")
  (%for-each proc tup))

;;; empty is the tuple which stores nothing
(define-with-contract (empty? x)
  "tests for an empty tuple"
  (and (%tuple? x) (= (%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-state sg)
  "returns the state of the single object sg"
  (domain (single? sg))
  (%state sg))

;;; 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))
  (%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) (= (%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"
  (%ref tup 0))

(define-with-contract (couple-right tup)
  "returns the right item of a couple"
  (%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) (= (%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"
  (%ref tup 0))

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

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

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

) ; module tuples