;;;;
;;;; r7rs.stk	-- R7RS support (Draft-3)
;;;;
;;;; Copyright © 2011 Erick Gallesio - Polytech'Nice-Sophia <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 31-Dec-2011 15:02 (eg)
;;;;

;;;; ----------------------------------------------------------------------
;;;; 6.4 Pairs and lists
;;;; ----------------------------------------------------------------------

#|
<doc R7RS make-list
 * (make-list k)
 * (make-list k fill)
 *
 * Returns a newly allocated list of k elements. If a second
 * argument is given, then each element is initialized to fill .
 * Otherwise the initial contents of each element is unspecified.
doc>
|#
(define (make-list k :optional (fill (void)))
  (vector->list (make-vector k fill)))



;;;; ----------------------------------------------------------------------
;;;; 6.8 Vectors
;;;; ----------------------------------------------------------------------
#|
<doc R7RS vector->string string->vector
 * (vector->string string)
 * (string->vector vector)
 *
 * |Vector->string| returns a newly allocated string of the
 * objects contained in the elements of |vector|, which must
 * be characters allowed in a string. |String->vector| returns
 * a newly created vector initialized to the elements of the
 * string |string|.
doc>
|#
(define (vector->string v)
  (unless (vector? v)
    (error "bad vector ~S" v))
  (let ((l (vector->list v)))
    (unless (every char? l)
      (error "all elements of the vector ~S must be characters" v))
    (list->string l)))

(define (string->vector str)
  (unless (string? str)
    (error "bad string ~S" str))
  (list->vector (string->list str)))

;;;; ----------------------------------------------------------------------
;;;; 6.9 Bytevectors
;;;; ----------------------------------------------------------------------
#|
<doc R7RS make-bytevector
 * (make-bytevector)
 *
 * Returns a newly allocated bytevector of k bytes. The initial
 * contents of each element is 0.
doc>
|#
(define (make-bytevector size :optional (default 0))
  (%make-uvector 1 size default))

#|
<doc R7RS bytevector?
 * (bytevector? obj)
 *
 * Returns |!t| if |obj| is a bytevector and returns |!f| otherwise.
doc>
|#
(define (bytevector? obj)
  (%uvector? 1 obj))

#|
<doc R7RS bytevector-length
 * (bytevector-length bytevector)
 *
 * Returns the length of |bytevector| in bytes as an exact integer.
doc>
|#
(define (bytevector-length bv)
  (%uvector-length 1 bv))

#|
<doc R7RS bytevector-u8-ref
 * (bytevector-u8-ref bytevector k)
 *
 * Returns the byte at index |k| of |bytevector| as an exact integer in the
 * range [0..255].
doc>
|#
(define (bytevector-u8-ref bv idx)
  (%uvector-ref 1 bv idx))

#|
<doc EXT bytevector-u8-set!
 * (bytevector-u8-ref bytevector k u8)
 *
 * Stores |u8| in  the byte at index |k| of |bytevector|. |u8| must be an
 * exact integer in the range [0..255].  The value returned by
 * |bytevector-u8-set!| is ,(emph "void").
doc>
|#
(define (bytevector-u8-set! bv idx val)
  (%uvector-set! 1 bv idx val))

#|
<doc R7RS bytevector-copy
 * (bytevector-copy bytevector)
 *
 * Returns a newly allocated bytevector containing the same bytes as |bytevector|.
doc>
|#
(define (bytevector-copy bv)
  (unless (bytevector? bv)
    (error "bad bytevector ~S" bv))

  (let* ((len (bytevector-length bv))
	 (new (make-bytevector len)))
    (dotimes (i len)
      (bytevector-u8-set! new i (bytevector-u8-ref bv i)))
    new))

#|
<doc R7RS bytevector-copy!
 * (bytevector-copy! from to)
 *
 * Copy the bytes of bytevector |from| to bytevector |to|, which must not be shorter.
 * The value returned by |bytevector-copy!| is ,(emph "void").
doc>
|#
(define (bytevector-copy! from to)
  (unless (bytevector? from)
    (error "bad bytevector ~S" from))
  (unless (bytevector? to)
    (error "bad bytevector ~S" to))
  (let ((len-from (bytevector-length from))
	(len-to   (bytevector-length to)))
    (when (> len-from len-to)
      (error "bytevector ~S is too long for copying it in ~S" from to))
    (dotimes (i len-from)
      (bytevector-u8-set! to i (bytevector-u8-ref from i)))))


#|
<doc R7RS bytevector-copy-partial
 * (bytevector-copy-partial bytevector start end)
 *
 * Returns a newly allocated bytevector containing the bytes in |bytevector|
 * between |start| (inclusive) and |end| (exclusive).
doc>
|#
(define (bytevector-copy-partial bv start end)
  (unless (bytevector? bv)
    (error "bad bytevector ~S" bv))
  (unless (integer? start)
    (error "bad starting index ~S" start))
  (unless (integer? end)
    (error "bad ending intex ~S" end))

  (let* ((len (- end start))
	 (new (make-bytevector len)))
    (dotimes (i len)
      (bytevector-u8-set! new i (bytevector-u8-ref bv (+ start i))))
    new))


#|
<doc R7RS bytevector-copy-partial!
 * (bytevector-copy-partial! from start end to at)
 *
 * Copy the bytes of |bytevector| from between |start| and |end| to bytevector
 * |to|, starting at |at|. The order in which bytes are copied
 * is unspecified, except that if the source and destination
 * overlap, copying takes place as if the source is first copied
 * into a temporary bytevector and then into the destination.
 * The value returned by |partial-bytevector-copy!| is ,(emph "void").
doc>
|#
(define (bytevector-copy-partial! from start end to at)
  (unless (bytevector? from)
    (error "bad bytevector ~S" from))
  (unless (bytevector? to)
    (error "bad bytevector ~S" to))
  (unless (integer? start)
    (error "bad starting index ~S" start))
  (unless (integer? end)
    (error "bad ending index ~S" end))
  (unless (integer? at)
    (error "bad destination index ~S" at))

  (let ((len    (- end start))
	(to-len (bytevector-length to)))
    (when (> (+ at len) to-len)
      (error "cannot copy ~S bytes in ~S starting at index ~S" len to at))

    (cond
      ((and (eq? from to) (= start at))
       ;; nothing to do
       (void))
      ((and (eq? from to) (> (+ at len) end))
       ;; may overlap => copy in reverse
       (let ((j (- (+ at len) 1))
	     (k (- end 1)))
	 (dotimes (i len)
	   (bytevector-u8-set! to (- j i) (bytevector-u8-ref from (- k i ))))))
      (else
       ;; normal copy
       (dotimes (i len)
	 (bytevector-u8-set! to (+ at i) (bytevector-u8-ref from (+ start i))))))))


;;;; ----------------------------------------------------------------------
;;;; 6.10 Control features
;;;; ----------------------------------------------------------------------

#|
<doc R7RS string-map
 * (string-map proc string1 string2 ...)
 *
 * The |strings| must be strings, and |proc| must be a procedure taking as
 * many arguments as there are strings and returning a single
 * value. If more than one string is given and not all strings have the
 * same length, |string-map| terminates when the shortest list runs
 * out. |String-map| applies |proc| element-wise to the elements of the
 * strings and returns a string of the results, in order. The dynamic
 * order in which proc is applied to the elements of the |strings| is
 * unspecified.
 * @lisp
 * (string-map char-downcase "AbdEgH")
 *          => "abdegh"
 *
 * (string-map
 *   (lambda (c)
 *     (integer->char (+ 1 (char->integer c))))
 *   "HAL")
 *          => "IBM"
 *
 * (string-map (lambda (c k)
 * 	      (if (eqv? k #\u)
 * 		  (char-upcase c)
 * 		  (char-downcase c)))
 * 	    "studlycaps"
 * 	    "ululululul")
 * 	 => "StUdLyCaPs"
 * @end lisp

doc>
|#
(define (string-map proc . strings)
  (let* ((strs (map (lambda (x)
		      (unless (string? x)
			(error 'string-map "bad string ~S" x))
		      (string->list x))
		    strings))
	 (res (apply map proc strs)))
    ;; Verify that every compnent of the result is a character
    (unless (every char? res)
      (error 'string-map "bad character in ~S" res))
    ;; Return result
    (list->string res)))

#|
<doc R7RS vector-map
 * (vector-map proc vector1 vector2 ...)
 *
 * The |vectors| must be vectors, and |proc| must be a procedure
 * taking as many arguments as there are vectors and returning a single
 * value. If more than one vector is given and not all vectors have the
 * same length, |vector-map| terminates when the shortest list runs
 * out. |Vector-map| applies |proc| element-wise to the elements of the
 * vectors and returns a vector of the results, in order. The dynamic
 * order in which proc is applied to the elements of the |vectors| is
 * unspecified.
 * @lisp
 * (vector-map cadr '#((a b) (d e) (g h)))
 *     =>  #(b e h)
 *
 * (vector-map (lambda (n) (expt n n))
 * 	    '#(1 2 3 4 5))
 *     => #(1 4 27 256 3125)
 *
 * (vector-map + '#(1 2 3) '#(4 5 6))
 *     => #(5 7 9)
 *
 * (let ((count 0))
 *   (vector-map
 *     (lambda (ignored)
 *       (set! count (+ count 1))
 *       count)
 *     '#(a b)))
 *     => #(1 2) or #(2 1)
 * @end lisp
doc>
|#
(define (vector-map proc . vectors)
  (unless (every vector? vectors)
    (error 'vector-map "bad list of vectors ~S" vectors))
  (list->vector (apply map proc (map vector->list vectors))))

#|
<doc R7RS string-for-each
 * (string-for-each proc string1 string2 ...)
 *
 * The arguments to |string-for-each| are like the arguments to
 * |string-map|, but |string-for-each| calls |proc| for its side effects
 * rather than for its values. Unlike |string-map|, |string-for-each| is
 * guaranteed to call |proc| on the elements of the lists in order from
 * the first element(s) to the last, and the value returned by
 * |string-for-each| is unspecified. If more than one string is given and
 * not all strings have the same length, |string-for-each| terminates when
 * the shortest string runs out.
 * @lisp
 * (let ((v (list)))
 *   (string-for-each (lambda (c) (set! v (cons (char->integer c) v)))
 * 	              "abcde")
 *    v)
 *        => (101 100 99 98 97)
 * @end lisp
doc>
|#
(define (string-for-each proc . strings)
  (let ((strs (map (lambda (x)
		     (unless (string? x)
		       (error 'string-for-each "bad string ~S" x))
		     (string->list x))
		   strings)))
    (apply map proc strs)
    (void)))


#|
<doc R7RS vector-for-each
 * (vector-for-each proc vector1 vector2 ...)
 *
 * The arguments to |vector-for-each| are like the arguments to
 * |vector-map|, but |vector-for-each| calls |proc| for its side effects
 * rather than for its values. Unlike |vector-map|, |vector-for-each| is
 * guaranteed to call |proc| on the elements of the lists in order from
 * the first element(s) to the last, and the value returned by
 * |vector-for-each| is unspecified. If more than one vector is given and
 * not all vectors have the same length, |vector-for-each| terminates when
 * the shortest vector runs out.
 * @lisp
 * (let ((v (make-vector 5)))
 *   (vector-for-each (lambda (i) (vector-set! v i (* i i)))
 * 		   '#(0 1 2 3 4))
 *   v)
 *        => #(0 1 4 9 16)
 * @end lisp
doc>
|#
(define (vector-for-each proc . vectors)
  (unless (every vector? vectors)
    (error 'vector-for-each "bad list of vectors ~S" vectors))
  (apply map proc (map vector->list vectors))
  (void))