;;;;
;;;; 160/TAG.stk         -- SRFI-160: Homogeneous numeric vector libraries
;;;;                                  (TAG sublibrary)
;;;;
;;;; Copyright © 2021 Jeronimo Pellegrini <j_p@aleph0.info>
;;;;
;;;;
;;;; 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: Jeronimo Pellegrini [j_p@aleph0.info]
;;;;    Creation date: 17-Jun-2022 15:54
;;;;

(define-module scheme/vector/TAG

  (import (srfi 4)
          (srfi 128)
          (scheme vector base))
  (export
   ;; Constructors
   make-TAGvector   ;; BASE
   TAGvector        ;; BASE
   TAGvector-unfold
   TAGvector-unfold-right
   TAGvector-copy
   TAGvector-reverse-copy
   TAGvector-append
   TAGvector-concatenate
   TAGvector-append-subvectors

   ;; Predicates
   TAG?              ;; BASE
   TAGvector?        ;; BASE
   TAGvector-empty?
   TAGvector=

   ;; Selectors
   TAGvector-ref     ;; BASE
   TAGvector-length  ;; BASE

   ;; Iteration
   TAGvector-take
   TAGvector-take-right
   TAGvector-drop
   TAGvector-drop-right
   TAGvector-segment
   TAGvector-fold
   TAGvector-fold-right
   TAGvector-map
   TAGvector-map!
   TAGvector-for-each
   TAGvector-count
   TAGvector-cumulate

   ;; Searching
   TAGvector-take-while
   TAGvector-take-while-right
   TAGvector-drop-while
   TAGvector-drop-while-right
   TAGvector-index
   TAGvector-index-right
   TAGvector-skip
   TAGvector-skip-right
   TAGvector-any
   TAGvector-every
   TAGvector-partition
   TAGvector-filter
   TAGvector-remove

   ;; Mutators
   TAGvector-set!            ;; BASE
   TAGvector-swap!
   TAGvector-fill!
   TAGvector-reverse!
   TAGvector-copy!
   TAGvector-reverse-copy!
   TAGvector-unfold!
   TAGvector-unfold-right!

   ;; Conversion
   TAGvector->list           ;; BASE
   reverse-TAGvector->list
   list->TAGvector           ;; BASE
   reverse-list->TAGvector
   TAGvector->vector
   vector->TAGvector

   ;; Generators
   make-TAGvector-generator

   ;; Comparators
   TAGvector-comparator

   ;; Output
   write-TAGvector)


;; A case of "macros for performance"... Not the best thing to do, we could
;; actually have done a more sofisticated job in generating the output from
;; the template, but this keeps it simple.
;; The macro (uvector-tag) will expand to TAG in the template.
;; However, in the generated file, the TAG will be replaed by the tag name.
;; So the macro will expand to the VALUE of the tag, which is the
;; fastest thing we can do. Not even access to a global will be done, the
;; correct constant will be pushed onto the stack.
;;
;;  (%s32vector-something (uvector-tag) args)
;; EXPANDS into
;;  (u8vector-something 4 args)
;; and NOT into
;;  (%u8vector-something s32 args)

(define-macro (uvector-tag)
  (let ((s8   0)
        (u8   1)
        (s16  2)
        (u16  3)
        (s32  4)
        (u32  5)
        (s64  6)
        (u64  7)
        (f32  8)
        (f64  9)
        (c64  10)
        (c128 11))
    TAG))

;; We'll be accessing the base module to get some procedures from it:
(define base (find-module 'scheme/vector/base))

;; These are implemented in C, and used here to build the actual procedures:
(define %uvector-unfold            (symbol-value '%uvector-unfold base))
(define %uvector-copy              (symbol-value '%uvector-copy base))
(define %uvector-append-subvectors (symbol-value '%uvector-append-subvectors base))
(define %uvector-empty?            (symbol-value '%uvector-empty? base))
(define %uvector=                  (symbol-value '%uvector= base))
(define %uvector-iterate           (symbol-value '%uvector-iterate base))
(define %uvector-segment           (symbol-value '%uvector-segment base))

;;;
;;; Constructors OK
;;;

;; make-vector OK
;; vector      OK

(define (TAGvector-unfold f len seed)
  (%uvector-unfold (uvector-tag) f #f len seed #f))

(define (TAGvector-unfold-right f len seed)
  (%uvector-unfold (uvector-tag) f #f len seed #t))

(define (TAGvector-copy v :optional (start 0) (end (TAGvector-length v)))
  (%uvector-copy (uvector-tag) #f 0 v start end #f))

(define (TAGvector-reverse-copy v :optional (start 0) (end (TAGvector-length v)))
  (%uvector-copy (uvector-tag) #f 0 v start end #t))

(define (TAGvector-append . vecs)
  (%uvector-append-subvectors (uvector-tag) #f vecs))

(define (TAGvector-concatenate vecs)
  (%uvector-append-subvectors (uvector-tag) #f vecs))

(define (TAGvector-append-subvectors . vecs)
  (%uvector-append-subvectors (uvector-tag) #t vecs))

;;;
;;; Predicates OK
;;;

(define (TAGvector-empty? v) (%uvector-empty? (uvector-tag) v))

(define (TAGvector= . args) (%uvector= (uvector-tag) args))

;;;
;;; Selectors OK
;;;

;; vector-ref    OK
;; vector-length OK

;; Iteration OK

(define (TAGvector-take v n) (TAGvector-copy v 0 n))
(define (TAGvector-take-right v n)
  (TAGvector-copy v (- (TAGvector-length v) n))) ; FIXME: optimize?

(define (TAGvector-drop v n)       (TAGvector-copy v n))
(define (TAGvector-drop-right v n)
  (%uvector-copy (uvector-tag) #f 0 v 0 (- (TAGvector-length v) n) #f)) ; FIXME: optimize?

(define (TAGvector-segment v n) (%uvector-segment (uvector-tag) v n))

(define (TAGvector-fold kons knil v1 . v2)
  (%uvector-iterate (uvector-tag) kons (cons v1 v2)
   #f   ;; do NOT mutate
   10   ;; operation (10 = fold)
   #f   ;; NOT from-right
   knil ;; seed
   ))

(define (TAGvector-fold-right kons knil v1 . v2)
  (%uvector-iterate (uvector-tag) kons (cons v1 v2)
   #f   ;; do NOT mutate
   10   ;; operation (10 = fold)
   #t   ;; YES from-right
   knil ;; seed
   ))

(define (TAGvector-map proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #f ;; do NOT mutate
   0  ;; operation (0 = map)
   #f ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-map! proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #t ;; DO mutate
   0  ;; operation (0 = map)
   #f ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-for-each proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #f ;; do NOT mutate
   9  ;; operation (9 = for-each)
   #f ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-count proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #f ;; do NOT mutate
   5  ;; operation (5 = count)
   #f ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-cumulate kons knil v1)
  (%uvector-iterate (uvector-tag) kons (list v1)
   #f   ;; do NOT mutate
   11   ;; operation (11 = cumulate)
   #f   ;; NOT from-right
   knil ;; seed
   ))

;;;
;;; Searching OK
;;;

(define (TAGvector-take-while pred? vec)
  (TAGvector-take vec (TAGvector-skip pred? vec)))

(define (TAGvector-take-while-right pred? vec)
  (TAGvector-drop vec (+ 1 (TAGvector-skip-right pred? vec))))

(define (TAGvector-drop-while pred? vec)
  (TAGvector-drop vec (TAGvector-skip pred? vec)))

(define (TAGvector-drop-while-right pred? vec)
  (TAGvector-take vec (+ 1 (TAGvector-skip-right pred? vec))))


(define (TAGvector-index proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #f ;; do NOT mutate
   3  ;; operation (3 = index)
   #f ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-index-right proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #f ;; do NOT mutate
   3  ;; operation (3 = index)
   #t ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-skip proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #f ;; do NOT mutate
   4  ;; operation (4 = skip)
   #f ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-skip-right proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #f ;; do NOT mutate
   4  ;; operation (4 = skip)
   #t ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-any proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #f ;; do NOT mutate
   1  ;; operation (1 = any)
   #f ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-every proc v1 . vs)
  (%uvector-iterate (uvector-tag) proc (cons v1 vs)
   #f ;; do NOT mutate
   2  ;; operation (2 = every)
   #f ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-partition proc v1)
  (%uvector-iterate (uvector-tag) proc (list v1)
   #f ;; do NOT mutate
   6  ;; operation (6 = partition)
   #f ;; NOT from-right
   #f ;; NO seed
   ))

(define (TAGvector-filter proc v1)
  (%uvector-iterate (uvector-tag) proc (list v1)
   #f ;; do NOT mutate
   7  ;; operation (7 = filter)
   #f ;; NOT from-right
   #f ;; NO seed
   ))
(define (TAGvector-remove proc v1)
  (%uvector-iterate (uvector-tag) proc (list v1)
   #f ;; do NOT mutate
   8  ;; operation (8 = remove)
   #f ;; NOT from-right
   #f ;; NO seed
   ))


;;;
;;; Mutators OK
;;;

;; vector-set! OK

;; FIXME:
;; vector-fill! and vector-swap! do not depend on vector type,
;; but vector-fill! does some type checking for each element
;; written. Maybe this could be optimized...
(define TAGvector-swap! (symbol-value '%uvector-swap!         base))
(define TAGvector-fill! (symbol-value '%uvector-fill!         base))

(define (TAGvector-reverse! v :optional (start 0) (end (TAGvector-length v)))
  (%uvector-copy (uvector-tag) v start v start end #t)
  #void)

(define (TAGvector-copy! to at from :optional (start 0) (end (TAGvector-length from)))
  (%uvector-copy (uvector-tag) to at from start end #f)
  #void)

(define (TAGvector-reverse-copy! to at from :optional (start 0) (end (TAGvector-length from)))
  (%uvector-copy (uvector-tag) to at from start end #t)
  #void)

(define (TAGvector-unfold! f v start end seed)
  (%uvector-unfold (uvector-tag) f v start end seed #f)
  #void)

(define (TAGvector-unfold-right! f v start end seed)
  (%uvector-unfold (uvector-tag) f v start end seed #t)
  #void)

;;;
;;; Conversion OK
;;;

(define (vector->TAGvector v :optional (start 0) (end (vector-length v)))
  (let* ((w (make-TAGvector (- end start))))
    (do ((i start (+ i 1)))
        ((= i end))
      (TAGvector-set! w (- i start) (vector-ref v i)))
    w))

(define (TAGvector->vector v :optional (start 0) (end (TAGvector-length v)))
  (let* ((w (make-vector (- end start))))
    (do ((i start (+ i 1)))
        ((= i end))
      (vector-set! w (- i start) (TAGvector-ref v i)))
    w))


(define (TAGvector->list v :optional (start 0) (end (TAGvector-length v)))
  (let ((v (TAGvector-copy v start end)))
    (let loop ((i (fx- (TAGvector-length v) 1))
               (lst '()))
      (if (fx< i 0)
          lst
          (loop (fx- i 1) (cons (TAGvector-ref v i) lst))))))


(define (reverse-list->TAGvector lst)
  (TAGvector-reverse-copy (list->TAGvector lst)))

(define (reverse-TAGvector->list v :optional (start 0) (end (TAGvector-length v)))
  (TAGvector->list (TAGvector-reverse-copy v start end)))

;;;
;;; Generators OK
;;;

(define (make-TAGvector-generator v :optional (start 0) (end (TAGvector-length v)))
  (lambda () (if (fx>= start end)
            (eof-object)
            (let ((x (TAGvector-ref v start)))
              (set! start (fx+ 1 start))
              x))))

;;;
;;; Comparators OK
;;;

;; Adapted from reference implementation in Chicken:
(define (TAGvector< vec1 vec2)
     (let ((len1 (TAGvector-length vec1))
           (len2 (TAGvector-length vec2)))
       (cond
         ((fx< (TAGvector-length vec1)
               (TAGvector-length vec2))
          #t)
         ((fx> (TAGvector-length vec1)
               (TAGvector-length vec2))
          #f)
         (else
          (let loop ((i 0))
            (cond
              ((fx= i len1) #f)
              ((< (TAGvector-ref vec1 i) (TAGvector-ref vec2 i))
               #t)
              ((> (TAGvector-ref vec1 i) (TAGvector-ref vec2 i))
               #f)
              (else
               (loop (fx+ i 1)))))))))

(define TAGvector-comparator
  (make-comparator TAGvector? TAGvector= TAGvector< hash-table-hash))

;;;
;;; Output OK
;;;

(define (write-TAGvector v :optional port)
  (unless ()
    (error))
  (if port
      (write v port)
      (write v)))

  )

(provide "scheme/vector/TAG")
