Changeset 38997 in project


Ignore:
Timestamp:
09/03/20 17:45:51 (3 weeks ago)
Author:
juergen
Message:

callable-sequences 1.2 with added operations

Location:
release/5/callable-sequences
Files:
3 edited
4 copied

Legend:

Unmodified
Added
Removed
  • release/5/callable-sequences/tags/1.2/callable-sequences.egg

    r38868 r38997  
    11;;;; callable-sequences.egg -*- Scheme -*-
    22
    3 ((synopsis "sequential- and random-access sequences as procedures")
     3((synopsis "Common functional interface to sequential- and random-access sequences")
    44 (category data)
    5  (version "1.1")
     5 (version "1.2")
    66 (license "BSD")
    7  (test-dependencies simple-tests)
     7 (test-dependencies simple-tests arrays)
    88 (author "Juergen Lorenz")
    99 (components (extension callable-sequences
  • release/5/callable-sequences/tags/1.2/callable-sequences.scm

    r38868 r38997  
     1; Copyright (c) 2020 , Juergen Lorenz, ju (at) jugilo (dot) de
     2; All rights reserved.
     3;
     4; Redistribution and use in source and binary forms, with or without
     5; modification, are permitted provided that the following conditions are
     6; met:
     7;
     8; Redistributions of source code must retain the above copyright
     9; notice, this list of conditions and the following disclaimer.
     10;
     11; Redistributions in binary form must reproduce the above copyright
     12; notice, this list of conditions and the following disclaimer in the
     13; documentation and/or other materials provided with the distribution.
     14; Neither the name of the author nor the names of its contributors may be
     15; used to endorse or promote products derived from this software without
     16; specific prior written permission.
     17;   
     18; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
     19; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
     20; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
     21; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
     22; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
     23; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
     24; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
     25; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
     26; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
     27; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
     28; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     29
     30
     31#|[
     32
     33This is a variant of Mario's callable-datastructures. But contrary to
     34that egg, I don't consider hash-tables, but only ordered sequences. So
     35it makes sense, to define slices. Moreover, I'll consider nested
     36sequences as well.
     37
     38Central to this module is a generic procedure, sequence-constructors, which
     39stores a local database initially supporting lists, pseudolists, vectors
     40and strings. But this database can be enhanced, by adding generic
     41constructors, make-sas-callable or make-ras-callable for sequential or
     42random access sequences respectively, the former following the list
     43pattern, the latter the vector pattern.
     44
     45Based on this, the most important procedure is make-callable, which
     46transforms an ordinary into a callable-sequence, i.e. a procedure of
     47zero, one or two arguments. With no argument, this returns i.a. the
     48encapsulated sequence, with one, an index, the value of that sequence at
     49the index and with two a slice between its two index arguments, in
     50either direction, the first included, the second excluded. For
     51convenience, the argument #f is allowed in slices, representing the
     52length.
     53
     54So, for example, if vec is (make-callable #(0 1 2 3 4 5)), then
     55(vec 1 4) or (vec 4 1) are callable-sequences encapsulating #(1 2 3)
     56or #(4 3 2) respectively, and (vec 3 #f) or (vec #f 3) encapsulate
     57#(3 4 5) or #(5 4) respectively.
     58
     59]|#
     60
    161(module callable-sequences (
     62  make-sas-callable
     63  callable-sas?
     64  make-ras-callable
     65  callable-ras?
     66  sequence?
     67  sequence-constructors
     68  make-callable
     69  callable?
     70  callable-null?
     71  callable-flat?
     72  callable-length
     73  callable-nil
     74  callable-data
     75  callable-indices
     76  callable-copy
     77  callable-map
     78  callable-for-each
     79  callable-filter
     80  callable-reverse
     81  callable-append
     82  callable-data*
     83  callable-map*
     84  make-callable*
    285  callable-sequences
    3   make-sas-callable
    4   make-ras-callable
    5   make-callable
    6   make-callable*
    7   callable-sas?
    8   callable-ras?
    9   callable?
    10   callable-length
    11   callable-null?
    12   callable-data
    13   callable-reverse
    1486  )
    1587
    16   (import scheme
    17           (only (chicken base) atom? receive gensym print error case-lambda)
    18           (only (chicken format) format)
    19           (only (chicken condition) condition-case)
    20           )
    21 
    22 ;;; a variant of Mario's callable-lists
    23 ;;; to be returned instead of lists in dotted-lambdas
    24 
     88(import scheme
     89        (only (chicken base) atom? receive gensym print error case-lambda)
     90        (only (chicken format) format)
     91        (only (chicken condition) condition-case)
     92        )
     93
     94(define (sas-nil seq seq-cons seq-car seq-cdr seq-null?)
     95  (let loop ((seq seq))
     96    (if (seq-null? seq)
     97      seq
     98      (loop (cdr seq)))))
     99
     100(define (ras-nil seq make-seq seq-ref seq-set! seq-length)
     101  (make-seq 0))
     102
     103(define (sas-reverse seq seq1 seq-cons seq-car seq-cdr seq-null?)
     104  (let loop ((seq seq)
     105             (result seq1));(sas-nil seq seq-cons seq-car seq-cdr seq-null?)))
     106    (if (seq-null? seq)
     107      result
     108      (loop (seq-cdr seq)
     109            (seq-cons (seq-car seq) result)))))
     110
     111(define (ras-reverse seq seq1 make-seq seq-ref seq-set! seq-length)
     112  (let ((len0 (seq-length seq)) (len1 (seq-length seq1)))
     113    (let* ((len (+ len0 len1)) (result (make-seq len)))
     114      (do ((k 0 (+ k 1)))
     115        ((= k len) result)
     116        (if (< k len0)
     117          (seq-set! result (- len0 k 1) (seq-ref seq k))
     118          (seq-set! result k (seq-ref seq (- k len0))))))))
     119
     120(define (sas-map fn seq seq-cons seq-car seq-cdr seq-null?)
     121  (let recur ((seq seq))
     122    (if (seq-null? seq)
     123      seq
     124      (seq-cons (fn (seq-car seq)) (recur (seq-cdr seq))))))
     125
     126(define (ras-map fn seq make-seq seq-ref seq-set! seq-length)
     127  (let* ((len (seq-length seq)) (result (make-seq len)))
     128    (do ((i 0 (+ i 1)))
     129      ((= i len) result)
     130      (seq-set! result i (fn (seq-ref seq i))))))
     131
     132(define (sas-filter ok? seq seq-cons seq-car seq-cdr seq-null?)
     133  (let loop ((seq seq)
     134             (seq-yes (sas-nil seq seq-cons seq-car seq-cdr seq-null?))
     135             (seq-no (sas-nil seq seq-cons seq-car seq-cdr seq-null?)))
     136    (cond
     137      ((seq-null? seq)
     138       (values (sas-reverse seq-yes seq-yes seq-cons seq-car seq-cdr seq-null?)
     139               (sas-reverse seq-no seq-no seq-cons seq-car seq-cdr seq-null?)))
     140      ((ok? (seq-car seq))
     141       (loop (seq-cdr seq) (seq-cons (seq-car seq) seq-yes) seq-no))
     142      (else
     143       (loop (seq-cdr seq) seq-yes (seq-cons (seq-car seq) seq-no))))))
     144
     145(define (ras-filter ok? seq make-seq seq-ref seq-set! seq-length)
     146  (let ((len (seq-length seq)))
     147    (receive (yes# no#)
     148      (let loop ((k 0) (yes 0) (no 0))
     149        (cond
     150          ((= k len)
     151           (values yes no))
     152          ((ok? (seq-ref seq k))
     153           (loop (+ k 1) (+ yes 1) no))
     154          (else
     155           (loop (+ k 1) yes (+ no 1)))
     156          ))
     157      (let ((seq-yes (make-seq yes#)) (seq-no (make-seq no#)))
     158        (do ((k 0 (+ k 1))
     159             (l 0)
     160             (m 0))
     161          ((= k len) (values seq-yes seq-no))
     162          (if (ok? (seq-ref seq k))
     163            (begin
     164              (seq-set! seq-yes l (seq-ref seq k))
     165              (set! l (+ l 1)))
     166            (begin
     167              (seq-set! seq-no m (seq-ref seq k))
     168              (set! m (+ m 1)))))))))
     169
     170(define (sas-append seq seq1 seq-cons seq-car seq-cdr seq-null?)
     171  (let recur ((seq seq))
     172    (if (seq-null? seq)
     173      seq1
     174      (seq-cons (seq-car seq) (recur (seq-cdr seq))))))
     175
     176;; seq and seq1 must be of same type
     177(define (ras-append seq seq1 make-seq seq-ref seq-set! seq-length)
     178  (let ((len (seq-length seq)) (len1 (seq-length seq1)))
     179    (let ((result (make-seq (+ len len1))))
     180      (do ((k 0 (+ k 1)))
     181        ((= k (+ len len1)) result)
     182        (seq-set! result k (if (< k len)
     183                             (seq-ref seq k)
     184                             (seq-ref seq1 (- k len))))
     185        ))))
     186
     187#|[
     188(make-sas-callable seq seq-cons seq-car seq-cdr seq-null?)
     189--- procedure ---
     190sequential access constructor with arguments similar to lists
     191]|#
    25192(define make-sas-callable 'make-sas-callable)
     193
     194#|[
     195(callable-sas? xpr)
     196--- procedure ---
     197evaluates xpr to a sequential access callable-sequence?
     198]|#
    26199(define callable-sas? 'callable-sas?)
     200
     201#|[
     202(make-ras-callable seq make-seq seq-ref seq-set! seq-length)
     203--- procedure ---
     204random access constructor with arguments similar to vectors
     205]|#
    27206(define make-ras-callable 'make-ras-callable)
     207
     208#|[
     209(callable-ras? xpr)
     210--- procedure ---
     211evaluates xpr to a random access callable-sequence?
     212]|#
    28213(define callable-ras? 'callable-ras?)
    29214
     215;; implementation of the four procedures above
    30216(let ((in (gensym 'in)) (sas (gensym 'sas)) (ras (gensym 'ras)))
    31217  (set! make-sas-callable
     
    38224              (loop (seq-cdr seq) (+ k 1))))
    39225          (case-lambda
    40             (() (values seq len))
     226            (()
     227             (values seq seq-cons seq-car seq-cdr seq-null?))
    41228            ((k)
    42229             (cond
     
    54241                                k len)))))
    55242            ((k l)
    56              (let ((revers (let loop ((seq seq) (revers nil))
    57                              (if (seq-null? seq)
    58                                revers
    59                                (loop (seq-cdr seq)
    60                                      (seq-cons (seq-car seq)
    61                                                revers))))))
     243             (let ((revers
     244                     (lambda (seq)
     245                       (let loop ((seq seq) (result nil))
     246                         (if (seq-null? seq)
     247                           (make-callable result)
     248                           (loop (seq-cdr seq)
     249                                 (seq-cons (seq-car seq)
     250                                           result)))))))
    62251               (cond
    63252                 ((and (integer? k) (integer? l)
     
    76265                 ((and (integer? k) (integer? l)
    77266                       (>= l -1) (< l k) (< k len))
    78                   ((maker revers) (- len k 1) (- len l 1)))
     267                  (revers (((maker seq) (+ l 1) (+ k 1)))))
    79268                 ((and (not k) (integer? l) (>= l -1))
    80                   ((maker revers) 0 (- len l 1)))
     269                  (revers (((maker seq) (+ l 1) k))))
    81270                 (else
    82271                   (error 'make-sas-callable
     
    96285        (let ((len (seq-length seq)))
    97286          (case-lambda
    98             (() (values seq len))
     287            (() (values seq make-seq seq-ref seq-set! seq-length))
    99288            ((k)
    100289             (cond
     
    143332  )
    144333
    145 (define (any? xpr) #t)
    146 
    147 (define make-callable
     334#|[
     335(sequence? xpr)
     336--- procedure ---
     337evaluates xpr to a sequence type, initially a list, pseudolist, vector
     338or string.
     339To be updated, if new sequence types are added.
     340]|#
     341(define (sequence? xpr)
     342  ;; standard sequences, to be updated by sequence-constructors
     343  (or (list? xpr)
     344      (pair? xpr)
     345      (vector? xpr)
     346      (string? xpr)))
     347
     348#|[
     349(sequence-constructors)
     350(sequence-constructors seq)
     351(sequence-constructors sym)
     352--- procedure ---
     353the first resets the internal database and the sequence? predicate,
     354the second selects and returns the constructor corresponding to the sequence
     355argument,
     356and the third adds a new sequential-access or random-access constructor,
     357according to the symbol 'sas or 'ras. sequence? is updated as well.
     358]|#
     359(define sequence-constructors
    148360  (let* (
    149361    (standard-db
    150362      (list
    151363        (cons list?
    152               (lambda (seq) (make-sas-callable seq
    153                                                cons
    154                                                car
    155                                                cdr
    156                                                null?)))
     364              (lambda (seq)
     365                (make-sas-callable seq
     366                                   cons
     367                                   car
     368                                   cdr
     369                                   null?)))
    157370        (cons pair?
    158               (lambda (seq) (make-sas-callable seq
    159                                                cons
    160                                                car
    161                                                cdr
    162                                                atom?)))
     371              (lambda (seq)
     372                (make-sas-callable seq
     373                                   cons
     374                                   car
     375                                   cdr
     376                                   atom?)))
    163377        (cons vector?
    164               (lambda (seq) (make-ras-callable seq
    165                                                make-vector
    166                                                vector-ref
    167                                                vector-set!
    168                                                vector-length)))
     378              (lambda (seq)
     379                (make-ras-callable seq
     380                                   make-vector
     381                                   vector-ref
     382                                   vector-set!
     383                                   vector-length)))
    169384        (cons string?
    170               (lambda (seq) (make-ras-callable seq
    171                                                make-string
    172                                                string-ref
    173                                                string-set!
    174                                                string-length)))
    175         (cons any?
    176               (lambda (seq) (error 'make-callable
    177                                    "not a sequence"
    178                                   seq)))
     385              (lambda (seq)
     386                (make-ras-callable seq
     387                                   make-string
     388                                   string-ref
     389                                   string-set!
     390                                   string-length)))
     391        (cons (lambda (x) #t)
     392              (lambda (seq)
     393                (error 'sequence "not a sequence" seq)))
    179394        ))
    180395    (db standard-db)
     396    (db->sequence?
     397      (lambda (db)
     398        (lambda (seq)
     399          (let loop ((tests (map car db)))
     400            (cond
     401              ((null? (cdr tests)) #f)
     402              (((car tests) seq) #t)
     403              (else (loop (cdr tests))))))))
    181404    )
    182405    (case-lambda
    183       (() ; reset database
     406      (()
     407       ;; reset database and seq?
    184408       (set! db standard-db)
    185        db)
    186       ((seq)
    187        (make-callable seq #f)) ; not recursive
    188       ((x y)
     409       (set! sequence? (db->sequence? db))
     410       (if #f #f))
     411      ((sym/seq)
    189412       (cond
    190          ((boolean? y)
    191           (let ((seq x) (recursive? y))
    192             (if recursive?
    193               (let* ((sequence?
    194                       (lambda (seq)
    195                         (let ((tests (map car (cdr (reverse db)))))
    196                           (if (memv #t (map (lambda (fn) (fn seq))
    197                                             tests))
    198                             #t #f))))
    199                      (cseq (make-callable seq))
    200                      (len (callable-length cseq)))
    201                 ;(print (map sequence? '(() #() (a . b) "" #f)))
    202                 (make-callable
    203                   (let recur ((i 0))
    204                     (cond
    205                       ((= i len)
    206                        (callable-data (cseq i #f)))
    207                       ((sequence? (cseq i))
    208                        (cons (make-callable (cseq i) #t) (recur (+ i 1))))
    209                       ((pair? (cseq i))
    210                        (cons (make-callable (cseq i) #t) (recur (+ i 1))))
    211                       (else
    212                         (cons (cseq i) (recur (+ i 1))))))))
    213               (let loop ((db db))
    214                 (if ((caar db) seq)
    215                   ((cdar db) seq)
    216                   (loop (cdr db)))))))
    217          ((and (procedure? x) (procedure? y))
    218           (let ((seq? x) (seq-maker y))
    219             ;; add new predicate-maker-pair as the next to last item
    220             (set! db
    221               (let recur ((db db))
    222                 (if (null? (cdr db))
    223                   (list (cons seq? seq-maker) (car db))
    224                   (cons (car db) (recur (cdr db))))))
    225             db))
    226          (else (error 'make-callable
    227                       "type mismatch" x y))))
    228       )))
    229 
    230 (define (make-callable* seq)
    231   (make-callable seq #t))
    232 
     413         ((symbol? sym/seq)
     414          ;; add new constructor
     415          (case sym/seq
     416            ((ras)
     417             (lambda (seq? seq-make seq-ref seq-set! seq-length)
     418               (set! db
     419                 (let recur ((db db))
     420                   (if (null? (cdr db))
     421                     (list
     422                       (cons seq?
     423                             (lambda (seq)
     424                               (make-ras-callable seq
     425                                                  seq-make
     426                                                  seq-ref
     427                                                  seq-set!
     428                                                  seq-length)))
     429                       (car db))
     430                     (cons (car db) (recur (cdr db))))))
     431               (set! sequence? (db->sequence? db))
     432               (if #f #f)))
     433            ((sas)
     434             (lambda (seq? seq-cons seq-car seq-cdr seq-null?)
     435               (set! db
     436                 (let recur ((db db))
     437                   (if (null? (cdr db))
     438                     (list
     439                       (cons seq?
     440                             (lambda (seq)
     441                               (make-ras-callable seq
     442                                                  seq-cons
     443                                                  seq-car
     444                                                  seq-cdr
     445                                                  seq-null?)))
     446                       (car db))
     447                     (cons (car db) (recur (cdr db))))))
     448               (set! sequence? ;seq?)
     449                 (lambda (seq)
     450                   (let ((tests (map car (reverse (cdr (reverse db))))))
     451                     (if (memv #t (map (lambda (fn) (fn seq))
     452                                       tests))
     453                         #t #f))))
     454               (if #f #f)))
     455            (else
     456              (error 'sequence-constructors "wrong sequence type" sym/seq))
     457            ))
     458         (else
     459           ;; return matching constructor
     460           (let loop ((db db))
     461             (if ((caar db) sym/seq)
     462               (cdar db)
     463               (loop (cdr db)))))
     464         )))))
     465
     466#|[
     467(make-callable seq)
     468--- procedure ---
     469makes the sequence seq callable
     470]|#
     471(define (make-callable seq)
     472  ((sequence-constructors seq) seq))
     473
     474#|[
     475(callable? xpr)
     476--- procedure ---
     477evaluates xpr to a callable sequence
     478]|#
    233479(define (callable? xpr)
    234480  (or (callable-sas? xpr)
    235481      (callable-ras? xpr)))
    236482
    237 (define (callable-length seq)
    238   (call-with-values seq (lambda (a b) b)))
    239 
    240 (define (callable-data seq)
    241   (call-with-values seq (lambda (a b) a)))
    242 
     483#|[
     484(callable-null? clb)
     485--- procedure ---
     486is the callable-sequence clb empty?
     487]|#
    243488(define (callable-null? xpr)
    244489  (and (callable? xpr) (zero? (callable-length xpr))))
    245490
    246 (define (callable-reverse seq)
    247   ;(seq (- (callable-length seq) 1) -1))
    248   (seq #f -1))
    249 
    250 ;;; (callable-sequences sym ..)
    251 ;;; -----------------------
    252 ;;; documentation procedure
     491#|[
     492(callable-flat? clb)
     493--- procedure ---
     494is the callable sequence clb flat?
     495]|#
     496(define (callable-flat? clb)
     497  (let ((len (callable-length clb)))
     498    (call-with-current-continuation
     499      (lambda (return)
     500        (let loop ((i 0))
     501            (if (= i len)
     502              #t
     503              (if (sequence? (clb i))
     504                (return #f)
     505                (loop (+ i 1)))))))))
     506    ;(do ((i 0 (+ i 1)))
     507    ;  ((= i len) result)
     508    ;  (if (sequence? (clb i)) (set! result #f)))))
     509
     510#|[
     511(callable-length clb)
     512--- procedure ---
     513returns the length of the callable sequence clb
     514]|#
     515(define (callable-length clb)
     516  (cond
     517    ((callable-sas? clb)
     518     (call-with-values clb
     519                       (lambda (seq seq-cons seq-car seq-cdr seq-null?)
     520                         (let loop ((seq seq) (k 0))
     521                           (if (seq-null? seq)
     522                             k
     523                             (loop (seq-cdr seq) (+ k 1)))))))
     524    ((callable-ras? clb)
     525     (call-with-values clb
     526                       (lambda (seq seq-make seq-ref seq-set! seq-length)
     527                         (seq-length seq))))
     528    (else (error 'callable-length
     529                 "sequence-type not implemented" (clb)))
     530    ))
     531
     532#|[
     533(callable-nil clb)
     534--- procedure ---
     535returns an empty callable sequence of the same type as clb
     536]|#
     537(define (callable-nil clb)
     538  ;; provide for atoms as pseudolist nils
     539  (let (
     540    (seq
     541      (cond
     542        ((callable-sas? clb)
     543         (apply sas-nil (call-with-values clb list)))
     544        ((callable-ras? clb)
     545         (apply ras-nil (call-with-values clb list)))
     546        (else
     547          (error 'callable-nil "sequence type not implemented" (clb)))))
     548    )
     549    (if (sequence? seq)
     550      (make-callable seq)
     551      seq)))
     552
     553#|[
     554(callable-data clb)
     555--- procedure ---
     556returns the encapsulated sequence of the flat callable-sequence clb
     557]|#
     558(define (callable-data clb)
     559  (clb))
     560
     561#|[
     562(callable-indices ok? clb)
     563--- procedure ---
     564returns the list of indices, k, for which (clb k) passes the ok? test
     565]|#
     566(define (callable-indices ok? clb)
     567  (let ((len (callable-length clb)))
     568    (let loop ((k 0) (result '()))
     569      (cond
     570        ((= k len) (reverse result))
     571        ((ok? (clb k))
     572         (loop (+ k 1) (cons k result)))
     573        (else
     574          (loop (+ k 1) result))))))
     575
     576#|[
     577(callable-copy clb)
     578--- procedure ---
     579returns a callable sequence which is a copy of the initial one
     580]|#
     581(define (callable-copy clb)
     582  (clb 0 #f))
     583
     584#|[
     585(callable-map fn clb)
     586--- procedure ---
     587maps the callable-sequence, clb, via procedure fn
     588]|#
     589(define (callable-map fn clb)
     590  (make-callable
     591    (cond
     592      ((callable-sas? clb)
     593       (apply sas-map fn (call-with-values clb list)))
     594      ((callable-ras? clb)
     595       (apply ras-map fn (call-with-values clb list)))
     596      (else
     597        (error 'callable-map "sequence-type not implemented" (clb))))))
     598
     599#|[
     600(callable-for-each fn clb)
     601--- procedure ---
     602executes fn for each item of clb
     603]|#
     604(define (callable-for-each fn clb)
     605  (let ((len (callable-length clb)))
     606    (do ((k 0 (+ k 1)))
     607      ((= k len) (if #f #f))
     608      (fn (clb k)))))
     609
     610#|[
     611(callable-filter ok? clb)
     612--- procedure ---
     613returnstwo callable sequences filtering items of clb
     614via ok? or not-ok? respectively
     615]|#
     616(define (callable-filter ok? clb)
     617  (cond
     618    ((callable-sas? clb)
     619     (receive (sas-yes sas-no)
     620       (apply sas-filter ok? (call-with-values clb list))
     621       (values (make-callable sas-yes) (make-callable sas-no))))
     622    ((callable-ras? clb)
     623     (receive (ras-yes ras-no)
     624       (apply ras-filter ok? (call-with-values clb list))
     625       (values (make-callable ras-yes) (make-callable ras-no))))
     626    (else
     627      (error 'callable-filter "sequence-type not implemented" (clb)))))
     628
     629#|[
     630(callable-reverse clb)
     631(callable-reverse clb clb1)
     632--- procedure ---
     633returns a callable sequence which is the reverse of the first argument
     634appended to the second one which defaults to callable-nil, if not given
     635]|#
     636(define callable-reverse
     637  (case-lambda
     638    ((clb clb1)
     639     (make-callable
     640       (cond
     641         ((and (callable-sas? clb) (callable-sas? clb1))
     642          (apply sas-reverse (clb) (call-with-values clb1 list)))
     643         ((and (callable-ras? clb) (callable-ras? clb1))
     644          (apply ras-reverse (clb) (call-with-values clb1 list)))
     645         (else
     646           (error 'callable-reverse "sequence types not equal" (clb) (clb1))))))
     647    ((clb)
     648     (callable-reverse clb (callable-nil clb)))
     649     ;(clb #f -1))
     650    ))
     651
     652#|[
     653(callable-append clb . clbs)
     654--- procedure ---
     655returns the callable sequence appending encapsulated sequences
     656of same type
     657]|#
     658(define (callable-append clb . clbs)
     659  (cond
     660    ((null? clbs) clb)
     661    ((null? (cdr clbs))
     662     (let ((clb1 (car clbs)))
     663       (let ((seq (clb)) (seq1 (clb1)))
     664         (make-callable
     665           (cond
     666             ((and (callable-sas? clb) (callable-sas? clb1))
     667              (apply sas-append seq (call-with-values clb1 list)))
     668             ((and (callable-ras? clb) (callable-ras? clb1))
     669              (apply ras-append seq (call-with-values clb1 list)))
     670             (else
     671               (error 'callable-append
     672                      "sequence-types different"
     673                      seq
     674                      seq1)))))))
     675    (else
     676      (callable-append clb
     677                       (apply callable-append
     678                              (car clbs)
     679                              (cdr clbs))))))
     680
     681
     682;;; nested sequences
     683
     684#|[
     685(callable-data* clb)
     686--- procedure ---
     687nested version of callable-data
     688]|#
     689(define (callable-data* clb)
     690  (callable-data
     691    (callable-map (lambda (x)
     692                    (if (callable? x)
     693                        (callable-data* x)
     694                        x))
     695                  clb
     696                  )))
     697
     698#|[
     699(callable-map* fn clb)
     700--- procedure ---
     701nested version of callable-map, i.e. maps a nested callable-sequence
     702]|#
     703(define (callable-map* fn clb)
     704  (callable-map
     705    (lambda (x)
     706      (if (callable? x)
     707        (callable-map* fn x)
     708        (fn x)))
     709    clb))
     710
     711#|[
     712(make-callable* seq)
     713--- procedure ---
     714nested version of make-callable, i.e. creates a nested callable-sequence
     715from a nested ordinary sequence
     716]|#
     717(define (make-callable* seq)
     718  (callable-map
     719    (lambda (x)
     720      (if (sequence? x)
     721          (make-callable* x)
     722          x))
     723    (make-callable seq)))
     724
     725#|[
     726(callable-sequences)
     727(callable-sequences sym)
     728--- procedure ---
     729documentation procedure
     730]|#
    253731(define callable-sequences
    254   (let ((syms '(callables make-callable callable? callable-length)))
    255     (case-lambda
    256       (() syms)
    257       ((sym)
    258        (if (memq sym syms)
    259          (case sym
    260            ((make-sas-callable)
    261             (print "  procedure:")
    262             (print "  (make-sas-callable seq seq-cons seq-car seq-cdr seq-null?)")
    263             (print "  returns a procedure with access to its")
    264             (print "  sequential-access sequence argument, including slices"))
    265            ((make-ras-callable)
    266             (print "  procedure:")
    267             (print "  (make-ras-callable seq make-seq seq-ref seq-set! seq-length)")
    268             (print "  returns a procedure with access to its")
    269             (print "  random-access sequence argument, including slices"))
    270            ((make-callable)
    271             (print "  generic procedure:")
    272             (print "  (make-callable)")
    273             (print "  (make-callable seq)")
    274             (print "  (make-callable seq? seq-maker)")
    275             (print "  the first resets the local database,")
    276             (print "  the second returns a procedure with access")
    277             (print "  to its sequence argument, including slices")
    278             (print "  and the third inserts a new item to the local")
    279             (print "  database in next to last position"))
    280            ((make-callable*)
    281             (print "  procdure:")
    282             (print "  (make-callable* seq)")
    283             (print "  recursive version of (make-callable seq"))
    284            ((callable-sas?)
    285             (print "  procedure:")
    286             (print "  type predicate for callable sequential-acces sequences"))
    287            ((callable-ras?)
    288             (print "  procedure:")
    289             (print "  type predicate for callable random-acces sequences"))
    290            ((callable?)
    291             (print "  procedure:")
    292             (print "  type predicate: either callable-sas? or callable-ras?"))
    293            ((callable-null? xpr)
    294             (print "  procedure:")
    295             (print "  xpr is callable? and its data are empty"))
    296            ((callable-length)
    297             (print "  procedure:")
    298             (print "  length of callable sequence"))
    299            ((callable-data)
    300             (print "  procedure:")
    301             (print "  encapsulated data of callable sequence"))
    302            ((callable-reverse)
    303             (print "  procedure:")
    304             (print "  reverse of callable sequence"))
    305            ((callables sym ..)
    306             (print "  procedure:")
    307             (print "  documentation procedure"))
    308            )
    309          (print "not in list " sym ", chose one of " syms)))
    310          )))
    311 ) ; module
    312 
    313 (import callable-sequences simple-tests)
    314 ;(define nil (make-callable '()))
    315 ;(define vec (make-callable #(0 1 2 3 4 5)))
    316 ;(define str (make-callable "012345"))
    317 ;(define lst (make-callable '(0 1 2 3 4 5)))
    318 ;(define pair (make-callable '(0 1 2 3 4 5 . 6)))
    319 ;(ppp (make-callable)
    320 ;     (make-callable boolean? identity)
    321 ;     )
    322 (define ls* (make-callable* '(a (b c))))
    323 (define pl* (make-callable* '(a (b . c))))
    324 (define lv* (make-callable* '(a #(b c))))
    325 (define vp* (make-callable* (vector 'a '(b . c))))
    326 (define vs* (make-callable* (vector 'a "bc")))
    327 (ppp (ls* 0)
    328      ((ls* 1) 1)
    329      (((ls* 1) 2 #f))
    330      ((pl* 1) 0)
    331      (((pl* 1) 1 #f))
    332      ((lv* 1) 1)
    333      ((vp* 1) 0)
    334      (((vp* 1) 1 #f))
    335      ((vs* 1) 0)
    336      ((vs* 1) 1)
    337      (((vs* 1) 2 #f))
    338      )
     732  (let (
     733    (alist '(
     734      (make-sas-callable
     735        procedure:
     736        (make-sas-callable seq seq-cons seq-car seq-cdr seq-null?)
     737        "sequential access constructor with arguments similar to lists"
     738        )
     739      (callable-sas?
     740        procedure:
     741        (callable-sas? xpr)
     742        "evaluates xpr to a sequential access callable-sequence?"
     743        )
     744      (make-ras-callable
     745        procedure:
     746        (make-ras-callable seq make-seq seq-ref seq-set! seq-length)
     747        "random access constructor with arguments similar to vectors"
     748        )
     749      (callable-ras?
     750        procedure:
     751        (callable-ras? xpr)
     752        "evaluates xpr to a random access callable-sequence?"
     753        )
     754      (sequence?
     755        procedure:
     756        (sequence? xpr)
     757        "evaluates xpr to a sequence type, initially a list, pseudolist, vector"
     758        "or string."
     759        "To be updated, if new sequence types are added."
     760        )
     761      (sequence-constructors
     762        procedure:
     763        (sequence-constructors)
     764        (sequence-constructors seq)
     765        (sequence-constructors sym)
     766        "the first resets the internal database and the sequence? predicate,"
     767        "the second selects and returns the constructor corresponding to the sequence"
     768        "argument,"
     769        "and the third adds a new sequential-access or random-access constructor,"
     770        "according to the symbol 'sas or 'ras. sequence? is updated as well."
     771        )
     772      (make-callable
     773        procedure:
     774        (make-callable seq)
     775        "makes the sequence seq callable"
     776        )
     777      (callable?
     778        procedure:
     779        (callable? xpr)
     780        "evaluates xpr to a callable sequence"
     781        )
     782      (callable-null?
     783        procedure:
     784        (callable-null? clb)
     785        "is the callable-sequence clb empty?"
     786        )
     787      (callable-flat?
     788        procedure:
     789        (callable-flat? clb)
     790        "is the callable sequence clb flat?"
     791        )
     792      (callable-length
     793        procedure:
     794        (callable-length clb)
     795        "returns the length of the callable sequence clb"
     796        )
     797      (callable-nil
     798        procedure:
     799        (callable-nil clb)
     800        "returns an empty callable sequence of the same type as clb"
     801        )
     802      (callable-data
     803        procedure:
     804        (callable-data clb)
     805        "returns the encapsulated sequence of the flat callable-sequence clb"
     806        )
     807      (callable-indices
     808        procedure:
     809        (callable-indices ok? clb)
     810        "returns the list of indices, k, for which (clb k) passes the ok? test"
     811        )
     812      (callable-copy
     813        procedure:
     814        (callable-copy clb)
     815        "returns a callable sequence which is a copy of the initial one"
     816        )
     817      (callable-map
     818        procedure:
     819        (callable-map fn clb)
     820        "maps the callable-sequence, clb, via procedure fn"
     821        )
     822      (callable-for-each
     823        procedure:
     824        (callable-for-each fn clb)
     825        "executes fn for each item of clb"
     826        )
     827      (callable-filter
     828        procedure:
     829        (callable-filter ok? clb)
     830        "returnstwo callable sequences filtering items of clb"
     831        "via ok? or not-ok? respectively"
     832        )
     833      (callable-reverse
     834        procedure:
     835        (callable-reverse clb)
     836        (callable-reverse clb clb1)
     837        "returns a callable sequence which is the reverse of the first argument"
     838        "appended to the second one which defaults to callable-nil, if not given"
     839        )
     840      (callable-append
     841        procedure:
     842        (callable-append clb . clbs)
     843        "returns the callable sequence appending encapsulated sequences"
     844        "of same type"
     845        )
     846      (callable-data*
     847        procedure:
     848        (callable-data* clb)
     849        "nested version of callable-data"
     850        )
     851      (callable-map*
     852        procedure:
     853        (callable-map* fn clb)
     854        "nested version of callable-map, i.e. maps a nested callable-sequence"
     855        )
     856      (make-callable*
     857        procedure:
     858        (make-callable* seq)
     859        "nested version of make-callable, i.e. creates a nested callable-sequence"
     860        "from a nested ordinary sequence"
     861        )
     862      (callable-sequences
     863        procedure:
     864        (callable-sequences)
     865        (callable-sequences sym)
     866        "with sym: documentation of exported symbol"
     867        "without sym: list of exported symbols"
     868        )
     869        ))
     870      )
     871      (case-lambda
     872        (() (map car alist))
     873        ((sym)
     874         (let ((pair (assq sym alist)))
     875           (if pair
     876             (for-each print (cdr pair))
     877             (print "Choose one of " (map car alist))))))))
     878)
  • release/5/callable-sequences/tags/1.2/tests/run.scm

    r38868 r38997  
    1 (import scheme callable-sequences simple-tests (chicken condition))
    2 
    3 
    4 (define-checks (callables? verbose?
    5                            pair
    6                            (make-callable '(0 1 2 3 4 5 . 6))
    7                            lst
    8                            (make-callable '(0 1 2 3 4 5))
    9                            vec
    10                            (make-callable #(0 1 2 3 4 5))
    11                            str
    12                            (make-callable "012345"))
    13 
    14   (callable-length pair)
     1
     2(import (chicken condition) callable-sequences simple-tests arrays)
     3
     4(define-checks
     5  (flat-access
     6    verbose?
     7    pls
     8    (make-callable '(0 1 2 3 4 5 . 6))
     9    lst
     10    (make-callable '(0 1 2 3 4 5))
     11    vec
     12    (make-callable #(0 1 2 3 4 5))
     13    str
     14    (make-callable "012345"))
     15  (callable-length pls)
    1516  6
    1617  (callable-length lst)
     
    2021  (callable-length vec)
    2122  6
     23  (callable-null? str)
     24  #f
     25  (callable-flat? vec)
     26  #t
    2227  (lst 0)
    2328  0
     
    3035  (lst 5)
    3136  5
    32   (condition-case (lst (callable-length lst))
    33     ((exn) #f))
    34   #f
    35   (condition-case (vec (callable-length vec))
    36     ((exn) #f))
    37   #f
    38   (condition-case (str (callable-length str))
    39     ((exn) #f))
     37  (condition-case (lst (callable-length lst)) ((exn) #f))
     38  #f
     39  (condition-case (vec (callable-length vec)) ((exn) #f))
     40  #f
     41  (condition-case (str (callable-length str)) ((exn) #f))
    4042  #f
    4143  (callable-data (lst 2 4))
     
    4547  (callable-length (lst 0 3))
    4648  3
    47   (callable-data (pair 0 3))
     49  (callable-data (pls 0 3))
    4850  '(0 1 2 . 6)
    49   (callable-data (pair 0 0))
    50   6
    51   (callable-null? (pair 3 3))
     51  ((pls 0 0))
     52  6
     53  (callable-data (pls 0 0))
     54  6
     55  (callable-null? (pls 3 3))
    5256  #t
    5357  (callable-null? (vec 1 2))
    5458  #f
    55   (callable-data (pair 3 0))
     59  (callable-data (pls 3 0))
    5660  '(3 2 1 . 6)
    5761  (callable-data (vec 0 3))
     
    6569  (callable-data (str 3 0))
    6670  "321"
    67   (callable-data (pair 0 #f))
     71  (callable-data (pls 0 #f))
    6872  '(0 1 2 3 4 5 . 6)
    69   (callable-data (pair 0 (callable-length pair)))
     73  (callable-data (pls 0 (callable-length pls)))
    7074  '(0 1 2 3 4 5 . 6)
    7175  (callable-data (lst 0 6))
     
    7579  (callable-data (str 0 #f))
    7680  "012345"
    77   (condition-case (lst 0 7)
    78     ((exn) #f))
    79   #f
    80   (condition-case (vec 0 7)
    81     ((exn) #f))
    82   #f
    83   (condition-case (str 0 7)
    84     ((exn) #f))
     81  (condition-case (lst 0 7) ((exn) #f))
     82  #f
     83  (condition-case (vec 0 7) ((exn) #f))
     84  #f
     85  (condition-case (str 0 7) ((exn) #f))
    8586  #f
    8687  (callable-data (lst 0 #f))
     
    106107  (callable-data (str (- (callable-length str) 1) -1))
    107108  "543210"
    108   (callable-data (callable-reverse str))
    109   "543210"
    110109  (callable-data (lst 3 1))
    111110  '(3 2)
     
    140139  (callable? #(0 1 2 3))
    141140  #f
     141  (sequence? #(0 1 2 3))
     142  #t
    142143  (callable? "0123")
    143144  #f
    144   (callable? "0123")
    145   #f
    146 )
    147 ;(callables?)
    148 
    149 (define-checks (recursives? verbose?
    150                             pl*
    151                             (make-callable* '(a (b . c)))
    152                             ls*
    153                             (make-callable* '(a (b c)))
    154                             lv*
    155                             (make-callable* '(a #(b c)))
    156                             vp*
    157                             (make-callable* (vector 'a '(b . c)))
    158                             vs*
    159                             (make-callable* (vector 'a "bc"))
    160                             lv**
    161                             (make-callable* '(a (b #(c d) e) f)))
     145  (sequence? "0123")
     146  #t
     147  (sequence? #f)
     148  #f)
     149
     150(define-checks
     151  (flat-operations
     152    verbose?
     153    pls
     154    (make-callable '(0 1 2 3 4 5 . 6))
     155    lst
     156    (make-callable '(0 1 2 3 4 5))
     157    vec
     158    (make-callable #(0 1 2 3 4 5))
     159    str
     160    (make-callable "012345"))
     161  (callable? pls)
     162  #t
     163  (callable? '())
     164  #f
     165  (callable-null? vec)
     166  #f
     167  (callable-null? (callable-nil vec))
     168  #t
     169  (callable-flat? vec)
     170  #t
     171  (callable-data (callable-nil vec))
     172  #()
     173  (callable-nil pls)
     174  6
     175  (callable-data (callable-reverse lst lst))
     176  '(5 4 3 2 1 0 0 1 2 3 4 5)
     177  (callable-data (callable-reverse str str))
     178  "543210012345"
     179  (callable-data (callable-reverse str))
     180  "543210"
     181  (callable-indices even? vec)
     182  '(0 2 4)
     183  (callable-indices odd? pls)
     184  '(1 3 5)
     185  (callable-data (callable-copy lst))
     186  '(0 1 2 3 4 5)
     187  (callable-data (callable-copy vec))
     188  #(0 1 2 3 4 5)
     189  (callable-data (callable-map add1 vec))
     190  #(1 2 3 4 5 6)
     191  (callable-data (callable-map add1 pls))
     192  '(1 2 3 4 5 6 . 6)
     193  (callable-for-each print vec)
     194  (if #f #f)
     195  (callable-data (callable-filter odd? vec))
     196  #(1 3 5)
     197  (receive (yes no) (callable-filter odd? vec) (list (yes) (no)))
     198  '(#(1 3 5) #(0 2 4))
     199  (callable-data (callable-append str str str))
     200  "012345012345012345"
     201  (callable-data (callable-append str str str str))
     202  "012345012345012345012345")
     203
     204(define-checks
     205  (nested-access
     206    verbose?
     207    pl*
     208    (make-callable* '(a (b . c)))
     209    ls*
     210    (make-callable* '(a (b c)))
     211    lv*
     212    (make-callable* '(a #(b c)))
     213    vp*
     214    (make-callable* (vector 'a '(b . c)))
     215    vs*
     216    (make-callable* (vector 'a "bc"))
     217    lv**
     218    (make-callable* '(a (b #(c d) e) f))
     219    ls**
     220    (make-callable* '(a (b (c) d) e))
     221    ns**
     222    (make-callable* '(0 (1 #(2) 3) 4)))
     223  (callable-data* pl*)
     224  '(a (b . c))
     225  (callable-data* lv**)
     226  '(a (b #(c d) e) f)
     227  (callable-data* ns**)
     228  '(0 (1 #(2) 3) 4)
     229  (callable-data* (callable-map* add1 ns**))
     230  '(1 (2 #(3) 4) 5)
    162231  (ls* 0)
    163232  'a
    164233  ((ls* 1) 1)
    165234  'c
    166   (((ls* 1) 2 #f))
     235  (callable-data ((ls* 1) 2 #f))
    167236  '()
     237  (callable? ((ls* 1) 1 2))
     238  #t
     239  (callable-data ((ls* 1) 1 2))
     240  '(c)
     241  (callable? pl*)
     242  #t
     243  (callable-data (pl* 1))
     244  '(b . c)
     245  (callable? (pl* 1))
     246  #t
    168247  ((pl* 1) 0)
    169248  'b
     249  (callable? ((pl* 1) 1 #f))
     250  #t
    170251  (((pl* 1) 1 #f))
    171252  'c
     253  (callable-data ((pl* 1) 1 #f))
     254  'c
    172255  ((lv* 1) 1)
    173256  'c
     257  (callable-data ((lv* 1) 1 2))
     258  #(c)
    174259  ((vp* 1) 0)
    175260  'b
     261  (callable? (vp* 1))
     262  #t
     263  (callable? ((vp* 1) 1 #f))
     264  #t
    176265  (((vp* 1) 1 #f))
     266  'c
     267  (callable-data ((vp* 1) 1 #f))
    177268  'c
    178269  ((vs* 1) 0)
     
    180271  ((vs* 1) 1)
    181272  #\c
    182   (((vs* 1) 2 #f))
     273  (callable-data ((vs* 1) 2 #f))
    183274  ""
    184275  (lv** 0)
     
    193284  'f
    194285  ((lv** 1) 2)
    195   'e
     286  'e)
     287
     288(define-checks
     289  (new-types verbose?)
     290  ((sequence-constructors 'ras)
     291   array?
     292   (lambda (k)
     293     (apply array
     294            (let loop ((i 0) (result '()))
     295              (if (= i k) result (loop (+ i 1) (cons #f result))))))
     296   (lambda (arr k) (array-at k arr))
     297   (lambda (arr k new) (array-update! k new arr))
     298   array-length)
     299  (if #f #f)
     300  (sequence? (make-array))
     301  #t
     302  (set! arr (make-callable (array 0 1 2 3)))
     303  (if #f #f)
     304  (arr 2)
     305  2
     306  (array-equal? (callable-data (arr 1 3)) (array 1 2))
     307  #t
     308  (array-equal? (callable-data (arr 3 #f)) (array 3))
     309  #t
     310  (array-equal? (callable-data (arr 3 1)) (array 3 2))
     311  #t
     312  (set! va* (make-callable* (vector 0 (array 1 2 3))))
     313  (if #f #f)
     314  (set! mva* (callable-map* add1 va*))
     315  (if #f #f)
     316  (mva* 0)
     317  1
     318  ((mva* 1) 0)
     319  2
     320  (array-equal? (callable-data (mva* 1)) (array 2 3 4))
     321  #t
     322  (sequence-constructors)
     323  (if #f #f)
     324  (sequence? (make-array))
     325  #f)
     326
     327(check-all CALLABLE-SEQUENCES
     328  (flat-access)
     329  (flat-operations)
     330  (nested-access)
     331  (new-types)
    196332  )
    197 ;(recursives?)
    198 
    199 (check-all CALLABLES (callables?) (recursives?))
    200 
  • release/5/callable-sequences/trunk/callable-sequences.egg

    r38868 r38997  
    11;;;; callable-sequences.egg -*- Scheme -*-
    22
    3 ((synopsis "sequential- and random-access sequences as procedures")
     3((synopsis "Common functional interface to sequential- and random-access sequences")
    44 (category data)
    5  (version "1.1")
     5 (version "1.2")
    66 (license "BSD")
    7  (test-dependencies simple-tests)
     7 (test-dependencies simple-tests arrays)
    88 (author "Juergen Lorenz")
    99 (components (extension callable-sequences
  • release/5/callable-sequences/trunk/callable-sequences.scm

    r38868 r38997  
     1; Copyright (c) 2020 , Juergen Lorenz, ju (at) jugilo (dot) de
     2; All rights reserved.
     3;
     4; Redistribution and use in source and binary forms, with or without
     5; modification, are permitted provided that the following conditions are
     6; met:
     7;
     8; Redistributions of source code must retain the above copyright
     9; notice, this list of conditions and the following disclaimer.
     10;
     11; Redistributions in binary form must reproduce the above copyright
     12; notice, this list of conditions and the following disclaimer in the
     13; documentation and/or other materials provided with the distribution.
     14; Neither the name of the author nor the names of its contributors may be
     15; used to endorse or promote products derived from this software without
     16; specific prior written permission.
     17;   
     18; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
     19; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
     20; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
     21; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
     22; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
     23; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
     24; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
     25; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
     26; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
     27; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
     28; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
     29
     30
     31#|[
     32
     33This is a variant of Mario's callable-datastructures. But contrary to
     34that egg, I don't consider hash-tables, but only ordered sequences. So
     35it makes sense, to define slices. Moreover, I'll consider nested
     36sequences as well.
     37
     38Central to this module is a generic procedure, sequence-constructors, which
     39stores a local database initially supporting lists, pseudolists, vectors
     40and strings. But this database can be enhanced, by adding generic
     41constructors, make-sas-callable or make-ras-callable for sequential or
     42random access sequences respectively, the former following the list
     43pattern, the latter the vector pattern.
     44
     45Based on this, the most important procedure is make-callable, which
     46transforms an ordinary into a callable-sequence, i.e. a procedure of
     47zero, one or two arguments. With no argument, this returns i.a. the
     48encapsulated sequence, with one, an index, the value of that sequence at
     49the index and with two a slice between its two index arguments, in
     50either direction, the first included, the second excluded. For
     51convenience, the argument #f is allowed in slices, representing the
     52length.
     53
     54So, for example, if vec is (make-callable #(0 1 2 3 4 5)), then
     55(vec 1 4) or (vec 4 1) are callable-sequences encapsulating #(1 2 3)
     56or #(4 3 2) respectively, and (vec 3 #f) or (vec #f 3) encapsulate
     57#(3 4 5) or #(5 4) respectively.
     58
     59]|#
     60
    161(module callable-sequences (
     62  make-sas-callable
     63  callable-sas?
     64  make-ras-callable
     65  callable-ras?
     66  sequence?
     67  sequence-constructors
     68  make-callable
     69  callable?
     70  callable-null?
     71  callable-flat?
     72  callable-length
     73  callable-nil
     74  callable-data
     75  callable-indices
     76  callable-copy
     77  callable-map
     78  callable-for-each
     79  callable-filter
     80  callable-reverse
     81  callable-append
     82  callable-data*
     83  callable-map*
     84  make-callable*
    285  callable-sequences
    3   make-sas-callable
    4   make-ras-callable
    5   make-callable
    6   make-callable*
    7   callable-sas?
    8   callable-ras?
    9   callable?
    10   callable-length
    11   callable-null?
    12   callable-data
    13   callable-reverse
    1486  )
    1587
    16   (import scheme
    17           (only (chicken base) atom? receive gensym print error case-lambda)
    18           (only (chicken format) format)
    19           (only (chicken condition) condition-case)
    20           )
    21 
    22 ;;; a variant of Mario's callable-lists
    23 ;;; to be returned instead of lists in dotted-lambdas
    24 
     88(import scheme
     89        (only (chicken base) atom? receive gensym print error case-lambda)
     90        (only (chicken format) format)
     91        (only (chicken condition) condition-case)
     92        )
     93
     94(define (sas-nil seq seq-cons seq-car seq-cdr seq-null?)
     95  (let loop ((seq seq))
     96    (if (seq-null? seq)
     97      seq
     98      (loop (cdr seq)))))
     99
     100(define (ras-nil seq make-seq seq-ref seq-set! seq-length)
     101  (make-seq 0))
     102
     103(define (sas-reverse seq seq1 seq-cons seq-car seq-cdr seq-null?)
     104  (let loop ((seq seq)
     105             (result seq1));(sas-nil seq seq-cons seq-car seq-cdr seq-null?)))
     106    (if (seq-null? seq)
     107      result
     108      (loop (seq-cdr seq)
     109            (seq-cons (seq-car seq) result)))))
     110
     111(define (ras-reverse seq seq1 make-seq seq-ref seq-set! seq-length)
     112  (let ((len0 (seq-length seq)) (len1 (seq-length seq1)))
     113    (let* ((len (+ len0 len1)) (result (make-seq len)))
     114      (do ((k 0 (+ k 1)))
     115        ((= k len) result)
     116        (if (< k len0)
     117          (seq-set! result (- len0 k 1) (seq-ref seq k))
     118          (seq-set! result k (seq-ref seq (- k len0))))))))
     119
     120(define (sas-map fn seq seq-cons seq-car seq-cdr seq-null?)
     121  (let recur ((seq seq))
     122    (if (seq-null? seq)
     123      seq
     124      (seq-cons (fn (seq-car seq)) (recur (seq-cdr seq))))))
     125
     126(define (ras-map fn seq make-seq seq-ref seq-set! seq-length)
     127  (let* ((len (seq-length seq)) (result (make-seq len)))
     128    (do ((i 0 (+ i 1)))
     129      ((= i len) result)
     130      (seq-set! result i (fn (seq-ref seq i))))))
     131
     132(define (sas-filter ok? seq seq-cons seq-car seq-cdr seq-null?)
     133  (let loop ((seq seq)
     134             (seq-yes (sas-nil seq seq-cons seq-car seq-cdr seq-null?))
     135             (seq-no (sas-nil seq seq-cons seq-car seq-cdr seq-null?)))
     136    (cond
     137      ((seq-null? seq)
     138       (values (sas-reverse seq-yes seq-yes seq-cons seq-car seq-cdr seq-null?)
     139               (sas-reverse seq-no seq-no seq-cons seq-car seq-cdr seq-null?)))
     140      ((ok? (seq-car seq))
     141       (loop (seq-cdr seq) (seq-cons (seq-car seq) seq-yes) seq-no))
     142      (else
     143       (loop (seq-cdr seq) seq-yes (seq-cons (seq-car seq) seq-no))))))
     144
     145(define (ras-filter ok? seq make-seq seq-ref seq-set! seq-length)
     146  (let ((len (seq-length seq)))
     147    (receive (yes# no#)
     148      (let loop ((k 0) (yes 0) (no 0))
     149        (cond
     150          ((= k len)
     151           (values yes no))
     152          ((ok? (seq-ref seq k))
     153           (loop (+ k 1) (+ yes 1) no))
     154          (else
     155           (loop (+ k 1) yes (+ no 1)))
     156          ))
     157      (let ((seq-yes (make-seq yes#)) (seq-no (make-seq no#)))
     158        (do ((k 0 (+ k 1))
     159             (l 0)
     160             (m 0))
     161          ((= k len) (values seq-yes seq-no))
     162          (if (ok? (seq-ref seq k))
     163            (begin
     164              (seq-set! seq-yes l (seq-ref seq k))
     165              (set! l (+ l 1)))
     166            (begin
     167              (seq-set! seq-no m (seq-ref seq k))
     168              (set! m (+ m 1)))))))))
     169
     170(define (sas-append seq seq1 seq-cons seq-car seq-cdr seq-null?)
     171  (let recur ((seq seq))
     172    (if (seq-null? seq)
     173      seq1
     174      (seq-cons (seq-car seq) (recur (seq-cdr seq))))))
     175
     176;; seq and seq1 must be of same type
     177(define (ras-append seq seq1 make-seq seq-ref seq-set! seq-length)
     178  (let ((len (seq-length seq)) (len1 (seq-length seq1)))
     179    (let ((result (make-seq (+ len len1))))
     180      (do ((k 0 (+ k 1)))
     181        ((= k (+ len len1)) result)
     182        (seq-set! result k (if (< k len)
     183                             (seq-ref seq k)
     184                             (seq-ref seq1 (- k len))))
     185        ))))
     186
     187#|[
     188(make-sas-callable seq seq-cons seq-car seq-cdr seq-null?)
     189--- procedure ---
     190sequential access constructor with arguments similar to lists
     191]|#
    25192(define make-sas-callable 'make-sas-callable)
     193
     194#|[
     195(callable-sas? xpr)
     196--- procedure ---
     197evaluates xpr to a sequential access callable-sequence?
     198]|#
    26199(define callable-sas? 'callable-sas?)
     200
     201#|[
     202(make-ras-callable seq make-seq seq-ref seq-set! seq-length)
     203--- procedure ---
     204random access constructor with arguments similar to vectors
     205]|#
    27206(define make-ras-callable 'make-ras-callable)
     207
     208#|[
     209(callable-ras? xpr)
     210--- procedure ---
     211evaluates xpr to a random access callable-sequence?
     212]|#
    28213(define callable-ras? 'callable-ras?)
    29214
     215;; implementation of the four procedures above
    30216(let ((in (gensym 'in)) (sas (gensym 'sas)) (ras (gensym 'ras)))
    31217  (set! make-sas-callable
     
    38224              (loop (seq-cdr seq) (+ k 1))))
    39225          (case-lambda
    40             (() (values seq len))
     226            (()
     227             (values seq seq-cons seq-car seq-cdr seq-null?))
    41228            ((k)
    42229             (cond
     
    54241                                k len)))))
    55242            ((k l)
    56              (let ((revers (let loop ((seq seq) (revers nil))
    57                              (if (seq-null? seq)
    58                                revers
    59                                (loop (seq-cdr seq)
    60                                      (seq-cons (seq-car seq)
    61                                                revers))))))
     243             (let ((revers
     244                     (lambda (seq)
     245                       (let loop ((seq seq) (result nil))
     246                         (if (seq-null? seq)
     247                           (make-callable result)
     248                           (loop (seq-cdr seq)
     249                                 (seq-cons (seq-car seq)
     250                                           result)))))))
    62251               (cond
    63252                 ((and (integer? k) (integer? l)
     
    76265                 ((and (integer? k) (integer? l)
    77266                       (>= l -1) (< l k) (< k len))
    78                   ((maker revers) (- len k 1) (- len l 1)))
     267                  (revers (((maker seq) (+ l 1) (+ k 1)))))
    79268                 ((and (not k) (integer? l) (>= l -1))
    80                   ((maker revers) 0 (- len l 1)))
     269                  (revers (((maker seq) (+ l 1) k))))
    81270                 (else
    82271                   (error 'make-sas-callable
     
    96285        (let ((len (seq-length seq)))
    97286          (case-lambda
    98             (() (values seq len))
     287            (() (values seq make-seq seq-ref seq-set! seq-length))
    99288            ((k)
    100289             (cond
     
    143332  )
    144333
    145 (define (any? xpr) #t)
    146 
    147 (define make-callable
     334#|[
     335(sequence? xpr)
     336--- procedure ---
     337evaluates xpr to a sequence type, initially a list, pseudolist, vector
     338or string.
     339To be updated, if new sequence types are added.
     340]|#
     341(define (sequence? xpr)
     342  ;; standard sequences, to be updated by sequence-constructors
     343  (or (list? xpr)
     344      (pair? xpr)
     345      (vector? xpr)
     346      (string? xpr)))
     347
     348#|[
     349(sequence-constructors)
     350(sequence-constructors seq)
     351(sequence-constructors sym)
     352--- procedure ---
     353the first resets the internal database and the sequence? predicate,
     354the second selects and returns the constructor corresponding to the sequence
     355argument,
     356and the third adds a new sequential-access or random-access constructor,
     357according to the symbol 'sas or 'ras. sequence? is updated as well.
     358]|#
     359(define sequence-constructors
    148360  (let* (
    149361    (standard-db
    150362      (list
    151363        (cons list?
    152               (lambda (seq) (make-sas-callable seq
    153                                                cons
    154                                                car
    155                                                cdr
    156                                                null?)))
     364              (lambda (seq)
     365                (make-sas-callable seq
     366                                   cons
     367                                   car
     368                                   cdr
     369                                   null?)))
    157370        (cons pair?
    158               (lambda (seq) (make-sas-callable seq
    159                                                cons
    160                                                car
    161                                                cdr
    162                                                atom?)))
     371              (lambda (seq)
     372                (make-sas-callable seq
     373                                   cons
     374                                   car
     375                                   cdr
     376                                   atom?)))
    163377        (cons vector?
    164               (lambda (seq) (make-ras-callable seq
    165                                                make-vector
    166                                                vector-ref
    167                                                vector-set!
    168                                                vector-length)))
     378              (lambda (seq)
     379                (make-ras-callable seq
     380                                   make-vector
     381                                   vector-ref
     382                                   vector-set!
     383                                   vector-length)))
    169384        (cons string?
    170               (lambda (seq) (make-ras-callable seq
    171                                                make-string
    172                                                string-ref
    173                                                string-set!
    174                                                string-length)))
    175         (cons any?
    176               (lambda (seq) (error 'make-callable
    177                                    "not a sequence"
    178                                   seq)))
     385              (lambda (seq)
     386                (make-ras-callable seq
     387                                   make-string
     388                                   string-ref
     389                                   string-set!
     390                                   string-length)))
     391        (cons (lambda (x) #t)
     392              (lambda (seq)
     393                (error 'sequence "not a sequence" seq)))
    179394        ))
    180395    (db standard-db)
     396    (db->sequence?
     397      (lambda (db)
     398        (lambda (seq)
     399          (let loop ((tests (map car db)))
     400            (cond
     401              ((null? (cdr tests)) #f)
     402              (((car tests) seq) #t)
     403              (else (loop (cdr tests))))))))
    181404    )
    182405    (case-lambda
    183       (() ; reset database
     406      (()
     407       ;; reset database and seq?
    184408       (set! db standard-db)
    185        db)
    186       ((seq)
    187        (make-callable seq #f)) ; not recursive
    188       ((x y)
     409       (set! sequence? (db->sequence? db))
     410       (if #f #f))
     411      ((sym/seq)
    189412       (cond
    190          ((boolean? y)
    191           (let ((seq x) (recursive? y))
    192             (if recursive?
    193               (let* ((sequence?
    194                       (lambda (seq)
    195                         (let ((tests (map car (cdr (reverse db)))))
    196                           (if (memv #t (map (lambda (fn) (fn seq))
    197                                             tests))
    198                             #t #f))))
    199                      (cseq (make-callable seq))
    200                      (len (callable-length cseq)))
    201                 ;(print (map sequence? '(() #() (a . b) "" #f)))
    202                 (make-callable
    203                   (let recur ((i 0))
    204                     (cond
    205                       ((= i len)
    206                        (callable-data (cseq i #f)))
    207                       ((sequence? (cseq i))
    208                        (cons (make-callable (cseq i) #t) (recur (+ i 1))))
    209                       ((pair? (cseq i))
    210                        (cons (make-callable (cseq i) #t) (recur (+ i 1))))
    211                       (else
    212                         (cons (cseq i) (recur (+ i 1))))))))
    213               (let loop ((db db))
    214                 (if ((caar db) seq)
    215                   ((cdar db) seq)
    216                   (loop (cdr db)))))))
    217          ((and (procedure? x) (procedure? y))
    218           (let ((seq? x) (seq-maker y))
    219             ;; add new predicate-maker-pair as the next to last item
    220             (set! db
    221               (let recur ((db db))
    222                 (if (null? (cdr db))
    223                   (list (cons seq? seq-maker) (car db))
    224                   (cons (car db) (recur (cdr db))))))
    225             db))
    226          (else (error 'make-callable
    227                       "type mismatch" x y))))
    228       )))
    229 
    230 (define (make-callable* seq)
    231   (make-callable seq #t))
    232 
     413         ((symbol? sym/seq)
     414          ;; add new constructor
     415          (case sym/seq
     416            ((ras)
     417             (lambda (seq? seq-make seq-ref seq-set! seq-length)
     418               (set! db
     419                 (let recur ((db db))
     420                   (if (null? (cdr db))
     421                     (list
     422                       (cons seq?
     423                             (lambda (seq)
     424                               (make-ras-callable seq
     425                                                  seq-make
     426                                                  seq-ref
     427                                                  seq-set!
     428                                                  seq-length)))
     429                       (car db))
     430                     (cons (car db) (recur (cdr db))))))
     431               (set! sequence? (db->sequence? db))
     432               (if #f #f)))
     433            ((sas)
     434             (lambda (seq? seq-cons seq-car seq-cdr seq-null?)
     435               (set! db
     436                 (let recur ((db db))
     437                   (if (null? (cdr db))
     438                     (list
     439                       (cons seq?
     440                             (lambda (seq)
     441                               (make-ras-callable seq
     442                                                  seq-cons
     443                                                  seq-car
     444                                                  seq-cdr
     445                                                  seq-null?)))
     446                       (car db))
     447                     (cons (car db) (recur (cdr db))))))
     448               (set! sequence? ;seq?)
     449                 (lambda (seq)
     450                   (let ((tests (map car (reverse (cdr (reverse db))))))
     451                     (if (memv #t (map (lambda (fn) (fn seq))
     452                                       tests))
     453                         #t #f))))
     454               (if #f #f)))
     455            (else
     456              (error 'sequence-constructors "wrong sequence type" sym/seq))
     457            ))
     458         (else
     459           ;; return matching constructor
     460           (let loop ((db db))
     461             (if ((caar db) sym/seq)
     462               (cdar db)
     463               (loop (cdr db)))))
     464         )))))
     465
     466#|[
     467(make-callable seq)
     468--- procedure ---
     469makes the sequence seq callable
     470]|#
     471(define (make-callable seq)
     472  ((sequence-constructors seq) seq))
     473
     474#|[
     475(callable? xpr)
     476--- procedure ---
     477evaluates xpr to a callable sequence
     478]|#
    233479(define (callable? xpr)
    234480  (or (callable-sas? xpr)
    235481      (callable-ras? xpr)))
    236482
    237 (define (callable-length seq)
    238   (call-with-values seq (lambda (a b) b)))
    239 
    240 (define (callable-data seq)
    241   (call-with-values seq (lambda (a b) a)))
    242 
     483#|[
     484(callable-null? clb)
     485--- procedure ---
     486is the callable-sequence clb empty?
     487]|#
    243488(define (callable-null? xpr)
    244489  (and (callable? xpr) (zero? (callable-length xpr))))
    245490
    246 (define (callable-reverse seq)
    247   ;(seq (- (callable-length seq) 1) -1))
    248   (seq #f -1))
    249 
    250 ;;; (callable-sequences sym ..)
    251 ;;; -----------------------
    252 ;;; documentation procedure
     491#|[
     492(callable-flat? clb)
     493--- procedure ---
     494is the callable sequence clb flat?
     495]|#
     496(define (callable-flat? clb)
     497  (let ((len (callable-length clb)))
     498    (call-with-current-continuation
     499      (lambda (return)
     500        (let loop ((i 0))
     501            (if (= i len)
     502              #t
     503              (if (sequence? (clb i))
     504                (return #f)
     505                (loop (+ i 1)))))))))
     506    ;(do ((i 0 (+ i 1)))
     507    ;  ((= i len) result)
     508    ;  (if (sequence? (clb i)) (set! result #f)))))
     509
     510#|[
     511(callable-length clb)
     512--- procedure ---
     513returns the length of the callable sequence clb
     514]|#
     515(define (callable-length clb)
     516  (cond
     517    ((callable-sas? clb)
     518     (call-with-values clb
     519                       (lambda (seq seq-cons seq-car seq-cdr seq-null?)
     520                         (let loop ((seq seq) (k 0))
     521                           (if (seq-null? seq)
     522                             k
     523                             (loop (seq-cdr seq) (+ k 1)))))))
     524    ((callable-ras? clb)
     525     (call-with-values clb
     526                       (lambda (seq seq-make seq-ref seq-set! seq-length)
     527                         (seq-length seq))))
     528    (else (error 'callable-length
     529                 "sequence-type not implemented" (clb)))
     530    ))
     531
     532#|[
     533(callable-nil clb)
     534--- procedure ---
     535returns an empty callable sequence of the same type as clb
     536]|#
     537(define (callable-nil clb)
     538  ;; provide for atoms as pseudolist nils
     539  (let (
     540    (seq
     541      (cond
     542        ((callable-sas? clb)
     543         (apply sas-nil (call-with-values clb list)))
     544        ((callable-ras? clb)
     545         (apply ras-nil (call-with-values clb list)))
     546        (else
     547          (error 'callable-nil "sequence type not implemented" (clb)))))
     548    )
     549    (if (sequence? seq)
     550      (make-callable seq)
     551      seq)))
     552
     553#|[
     554(callable-data clb)
     555--- procedure ---
     556returns the encapsulated sequence of the flat callable-sequence clb
     557]|#
     558(define (callable-data clb)
     559  (clb))
     560
     561#|[
     562(callable-indices ok? clb)
     563--- procedure ---
     564returns the list of indices, k, for which (clb k) passes the ok? test
     565]|#
     566(define (callable-indices ok? clb)
     567  (let ((len (callable-length clb)))
     568    (let loop ((k 0) (result '()))
     569      (cond
     570        ((= k len) (reverse result))
     571        ((ok? (clb k))
     572         (loop (+ k 1) (cons k result)))
     573        (else
     574          (loop (+ k 1) result))))))
     575
     576#|[
     577(callable-copy clb)
     578--- procedure ---
     579returns a callable sequence which is a copy of the initial one
     580]|#
     581(define (callable-copy clb)
     582  (clb 0 #f))
     583
     584#|[
     585(callable-map fn clb)
     586--- procedure ---
     587maps the callable-sequence, clb, via procedure fn
     588]|#
     589(define (callable-map fn clb)
     590  (make-callable
     591    (cond
     592      ((callable-sas? clb)
     593       (apply sas-map fn (call-with-values clb list)))
     594      ((callable-ras? clb)
     595       (apply ras-map fn (call-with-values clb list)))
     596      (else
     597        (error 'callable-map "sequence-type not implemented" (clb))))))
     598
     599#|[
     600(callable-for-each fn clb)
     601--- procedure ---
     602executes fn for each item of clb
     603]|#
     604(define (callable-for-each fn clb)
     605  (let ((len (callable-length clb)))
     606    (do ((k 0 (+ k 1)))
     607      ((= k len) (if #f #f))
     608      (fn (clb k)))))
     609
     610#|[
     611(callable-filter ok? clb)
     612--- procedure ---
     613returnstwo callable sequences filtering items of clb
     614via ok? or not-ok? respectively
     615]|#
     616(define (callable-filter ok? clb)
     617  (cond
     618    ((callable-sas? clb)
     619     (receive (sas-yes sas-no)
     620       (apply sas-filter ok? (call-with-values clb list))
     621       (values (make-callable sas-yes) (make-callable sas-no))))
     622    ((callable-ras? clb)
     623     (receive (ras-yes ras-no)
     624       (apply ras-filter ok? (call-with-values clb list))
     625       (values (make-callable ras-yes) (make-callable ras-no))))
     626    (else
     627      (error 'callable-filter "sequence-type not implemented" (clb)))))
     628
     629#|[
     630(callable-reverse clb)
     631(callable-reverse clb clb1)
     632--- procedure ---
     633returns a callable sequence which is the reverse of the first argument
     634appended to the second one which defaults to callable-nil, if not given
     635]|#
     636(define callable-reverse
     637  (case-lambda
     638    ((clb clb1)
     639     (make-callable
     640       (cond
     641         ((and (callable-sas? clb) (callable-sas? clb1))
     642          (apply sas-reverse (clb) (call-with-values clb1 list)))
     643         ((and (callable-ras? clb) (callable-ras? clb1))
     644          (apply ras-reverse (clb) (call-with-values clb1 list)))
     645         (else
     646           (error 'callable-reverse "sequence types not equal" (clb) (clb1))))))
     647    ((clb)
     648     (callable-reverse clb (callable-nil clb)))
     649     ;(clb #f -1))
     650    ))
     651
     652#|[
     653(callable-append clb . clbs)
     654--- procedure ---
     655returns the callable sequence appending encapsulated sequences
     656of same type
     657]|#
     658(define (callable-append clb . clbs)
     659  (cond
     660    ((null? clbs) clb)
     661    ((null? (cdr clbs))
     662     (let ((clb1 (car clbs)))
     663       (let ((seq (clb)) (seq1 (clb1)))
     664         (make-callable
     665           (cond
     666             ((and (callable-sas? clb) (callable-sas? clb1))
     667              (apply sas-append seq (call-with-values clb1 list)))
     668             ((and (callable-ras? clb) (callable-ras? clb1))
     669              (apply ras-append seq (call-with-values clb1 list)))
     670             (else
     671               (error 'callable-append
     672                      "sequence-types different"
     673                      seq
     674                      seq1)))))))
     675    (else
     676      (callable-append clb
     677                       (apply callable-append
     678                              (car clbs)
     679                              (cdr clbs))))))
     680
     681
     682;;; nested sequences
     683
     684#|[
     685(callable-data* clb)
     686--- procedure ---
     687nested version of callable-data
     688]|#
     689(define (callable-data* clb)
     690  (callable-data
     691    (callable-map (lambda (x)
     692                    (if (callable? x)
     693                        (callable-data* x)
     694                        x))
     695                  clb
     696                  )))
     697
     698#|[
     699(callable-map* fn clb)
     700--- procedure ---
     701nested version of callable-map, i.e. maps a nested callable-sequence
     702]|#
     703(define (callable-map* fn clb)
     704  (callable-map
     705    (lambda (x)
     706      (if (callable? x)
     707        (callable-map* fn x)
     708        (fn x)))
     709    clb))
     710
     711#|[
     712(make-callable* seq)
     713--- procedure ---
     714nested version of make-callable, i.e. creates a nested callable-sequence
     715from a nested ordinary sequence
     716]|#
     717(define (make-callable* seq)
     718  (callable-map
     719    (lambda (x)
     720      (if (sequence? x)
     721          (make-callable* x)
     722          x))
     723    (make-callable seq)))
     724
     725#|[
     726(callable-sequences)
     727(callable-sequences sym)
     728--- procedure ---
     729documentation procedure
     730]|#
    253731(define callable-sequences
    254   (let ((syms '(callables make-callable callable? callable-length)))
    255     (case-lambda
    256       (() syms)
    257       ((sym)
    258        (if (memq sym syms)
    259          (case sym
    260            ((make-sas-callable)
    261             (print "  procedure:")
    262             (print "  (make-sas-callable seq seq-cons seq-car seq-cdr seq-null?)")
    263             (print "  returns a procedure with access to its")
    264             (print "  sequential-access sequence argument, including slices"))
    265            ((make-ras-callable)
    266             (print "  procedure:")
    267             (print "  (make-ras-callable seq make-seq seq-ref seq-set! seq-length)")
    268             (print "  returns a procedure with access to its")
    269             (print "  random-access sequence argument, including slices"))
    270            ((make-callable)
    271             (print "  generic procedure:")
    272             (print "  (make-callable)")
    273             (print "  (make-callable seq)")
    274             (print "  (make-callable seq? seq-maker)")
    275             (print "  the first resets the local database,")
    276             (print "  the second returns a procedure with access")
    277             (print "  to its sequence argument, including slices")
    278             (print "  and the third inserts a new item to the local")
    279             (print "  database in next to last position"))
    280            ((make-callable*)
    281             (print "  procdure:")
    282             (print "  (make-callable* seq)")
    283             (print "  recursive version of (make-callable seq"))
    284            ((callable-sas?)
    285             (print "  procedure:")
    286             (print "  type predicate for callable sequential-acces sequences"))
    287            ((callable-ras?)
    288             (print "  procedure:")
    289             (print "  type predicate for callable random-acces sequences"))
    290            ((callable?)
    291             (print "  procedure:")
    292             (print "  type predicate: either callable-sas? or callable-ras?"))
    293            ((callable-null? xpr)
    294             (print "  procedure:")
    295             (print "  xpr is callable? and its data are empty"))
    296            ((callable-length)
    297             (print "  procedure:")
    298             (print "  length of callable sequence"))
    299            ((callable-data)
    300             (print "  procedure:")
    301             (print "  encapsulated data of callable sequence"))
    302            ((callable-reverse)
    303             (print "  procedure:")
    304             (print "  reverse of callable sequence"))
    305            ((callables sym ..)
    306             (print "  procedure:")
    307             (print "  documentation procedure"))
    308            )
    309          (print "not in list " sym ", chose one of " syms)))
    310          )))
    311 ) ; module
    312 
    313 (import callable-sequences simple-tests)
    314 ;(define nil (make-callable '()))
    315 ;(define vec (make-callable #(0 1 2 3 4 5)))
    316 ;(define str (make-callable "012345"))
    317 ;(define lst (make-callable '(0 1 2 3 4 5)))
    318 ;(define pair (make-callable '(0 1 2 3 4 5 . 6)))
    319 ;(ppp (make-callable)
    320 ;     (make-callable boolean? identity)
    321 ;     )
    322 (define ls* (make-callable* '(a (b c))))
    323 (define pl* (make-callable* '(a (b . c))))
    324 (define lv* (make-callable* '(a #(b c))))
    325 (define vp* (make-callable* (vector 'a '(b . c))))
    326 (define vs* (make-callable* (vector 'a "bc")))
    327 (ppp (ls* 0)
    328      ((ls* 1) 1)
    329      (((ls* 1) 2 #f))
    330      ((pl* 1) 0)
    331      (((pl* 1) 1 #f))
    332      ((lv* 1) 1)
    333      ((vp* 1) 0)
    334      (((vp* 1) 1 #f))
    335      ((vs* 1) 0)
    336      ((vs* 1) 1)
    337      (((vs* 1) 2 #f))
    338      )
     732  (let (
     733    (alist '(
     734      (make-sas-callable
     735        procedure:
     736        (make-sas-callable seq seq-cons seq-car seq-cdr seq-null?)
     737        "sequential access constructor with arguments similar to lists"
     738        )
     739      (callable-sas?
     740        procedure:
     741        (callable-sas? xpr)
     742        "evaluates xpr to a sequential access callable-sequence?"
     743        )
     744      (make-ras-callable
     745        procedure:
     746        (make-ras-callable seq make-seq seq-ref seq-set! seq-length)
     747        "random access constructor with arguments similar to vectors"
     748        )
     749      (callable-ras?
     750        procedure:
     751        (callable-ras? xpr)
     752        "evaluates xpr to a random access callable-sequence?"
     753        )
     754      (sequence?
     755        procedure:
     756        (sequence? xpr)
     757        "evaluates xpr to a sequence type, initially a list, pseudolist, vector"
     758        "or string."
     759        "To be updated, if new sequence types are added."
     760        )
     761      (sequence-constructors
     762        procedure:
     763        (sequence-constructors)
     764        (sequence-constructors seq)
     765        (sequence-constructors sym)
     766        "the first resets the internal database and the sequence? predicate,"
     767        "the second selects and returns the constructor corresponding to the sequence"
     768        "argument,"
     769        "and the third adds a new sequential-access or random-access constructor,"
     770        "according to the symbol 'sas or 'ras. sequence? is updated as well."
     771        )
     772      (make-callable
     773        procedure:
     774        (make-callable seq)
     775        "makes the sequence seq callable"
     776        )
     777      (callable?
     778        procedure:
     779        (callable? xpr)
     780        "evaluates xpr to a callable sequence"
     781        )
     782      (callable-null?
     783        procedure:
     784        (callable-null? clb)
     785        "is the callable-sequence clb empty?"
     786        )
     787      (callable-flat?
     788        procedure:
     789        (callable-flat? clb)
     790        "is the callable sequence clb flat?"
     791        )
     792      (callable-length
     793        procedure:
     794        (callable-length clb)
     795        "returns the length of the callable sequence clb"
     796        )
     797      (callable-nil
     798        procedure:
     799        (callable-nil clb)
     800        "returns an empty callable sequence of the same type as clb"
     801        )
     802      (callable-data
     803        procedure:
     804        (callable-data clb)
     805        "returns the encapsulated sequence of the flat callable-sequence clb"
     806        )
     807      (callable-indices
     808        procedure:
     809        (callable-indices ok? clb)
     810        "returns the list of indices, k, for which (clb k) passes the ok? test"
     811        )
     812      (callable-copy
     813        procedure:
     814        (callable-copy clb)
     815        "returns a callable sequence which is a copy of the initial one"
     816        )
     817      (callable-map
     818        procedure:
     819        (callable-map fn clb)
     820        "maps the callable-sequence, clb, via procedure fn"
     821        )
     822      (callable-for-each
     823        procedure:
     824        (callable-for-each fn clb)
     825        "executes fn for each item of clb"
     826        )
     827      (callable-filter
     828        procedure:
     829        (callable-filter ok? clb)
     830        "returnstwo callable sequences filtering items of clb"
     831        "via ok? or not-ok? respectively"
     832        )
     833      (callable-reverse
     834        procedure:
     835        (callable-reverse clb)
     836        (callable-reverse clb clb1)
     837        "returns a callable sequence which is the reverse of the first argument"
     838        "appended to the second one which defaults to callable-nil, if not given"
     839        )
     840      (callable-append
     841        procedure:
     842        (callable-append clb . clbs)
     843        "returns the callable sequence appending encapsulated sequences"
     844        "of same type"
     845        )
     846      (callable-data*
     847        procedure:
     848        (callable-data* clb)
     849        "nested version of callable-data"
     850        )
     851      (callable-map*
     852        procedure:
     853        (callable-map* fn clb)
     854        "nested version of callable-map, i.e. maps a nested callable-sequence"
     855        )
     856      (make-callable*
     857        procedure:
     858        (make-callable* seq)
     859        "nested version of make-callable, i.e. creates a nested callable-sequence"
     860        "from a nested ordinary sequence"
     861        )
     862      (callable-sequences
     863        procedure:
     864        (callable-sequences)
     865        (callable-sequences sym)
     866        "with sym: documentation of exported symbol"
     867        "without sym: list of exported symbols"
     868        )
     869        ))
     870      )
     871      (case-lambda
     872        (() (map car alist))
     873        ((sym)
     874         (let ((pair (assq sym alist)))
     875           (if pair
     876             (for-each print (cdr pair))
     877             (print "Choose one of " (map car alist))))))))
     878)
  • release/5/callable-sequences/trunk/tests/run.scm

    r38868 r38997  
    1 (import scheme callable-sequences simple-tests (chicken condition))
    2 
    3 
    4 (define-checks (callables? verbose?
    5                            pair
    6                            (make-callable '(0 1 2 3 4 5 . 6))
    7                            lst
    8                            (make-callable '(0 1 2 3 4 5))
    9                            vec
    10                            (make-callable #(0 1 2 3 4 5))
    11                            str
    12                            (make-callable "012345"))
    13 
    14   (callable-length pair)
     1
     2(import (chicken condition) callable-sequences simple-tests arrays)
     3
     4(define-checks
     5  (flat-access
     6    verbose?
     7    pls
     8    (make-callable '(0 1 2 3 4 5 . 6))
     9    lst
     10    (make-callable '(0 1 2 3 4 5))
     11    vec
     12    (make-callable #(0 1 2 3 4 5))
     13    str
     14    (make-callable "012345"))
     15  (callable-length pls)
    1516  6
    1617  (callable-length lst)
     
    2021  (callable-length vec)
    2122  6
     23  (callable-null? str)
     24  #f
     25  (callable-flat? vec)
     26  #t
    2227  (lst 0)
    2328  0
     
    3035  (lst 5)
    3136  5
    32   (condition-case (lst (callable-length lst))
    33     ((exn) #f))
    34   #f
    35   (condition-case (vec (callable-length vec))
    36     ((exn) #f))
    37   #f
    38   (condition-case (str (callable-length str))
    39     ((exn) #f))
     37  (condition-case (lst (callable-length lst)) ((exn) #f))
     38  #f
     39  (condition-case (vec (callable-length vec)) ((exn) #f))
     40  #f
     41  (condition-case (str (callable-length str)) ((exn) #f))
    4042  #f
    4143  (callable-data (lst 2 4))
     
    4547  (callable-length (lst 0 3))
    4648  3
    47   (callable-data (pair 0 3))
     49  (callable-data (pls 0 3))
    4850  '(0 1 2 . 6)
    49   (callable-data (pair 0 0))
    50   6
    51   (callable-null? (pair 3 3))
     51  ((pls 0 0))
     52  6
     53  (callable-data (pls 0 0))
     54  6
     55  (callable-null? (pls 3 3))
    5256  #t
    5357  (callable-null? (vec 1 2))
    5458  #f
    55   (callable-data (pair 3 0))
     59  (callable-data (pls 3 0))
    5660  '(3 2 1 . 6)
    5761  (callable-data (vec 0 3))
     
    6569  (callable-data (str 3 0))
    6670  "321"
    67   (callable-data (pair 0 #f))
     71  (callable-data (pls 0 #f))
    6872  '(0 1 2 3 4 5 . 6)
    69   (callable-data (pair 0 (callable-length pair)))
     73  (callable-data (pls 0 (callable-length pls)))
    7074  '(0 1 2 3 4 5 . 6)
    7175  (callable-data (lst 0 6))
     
    7579  (callable-data (str 0 #f))
    7680  "012345"
    77   (condition-case (lst 0 7)
    78     ((exn) #f))
    79   #f
    80   (condition-case (vec 0 7)
    81     ((exn) #f))
    82   #f
    83   (condition-case (str 0 7)
    84     ((exn) #f))
     81  (condition-case (lst 0 7) ((exn) #f))
     82  #f
     83  (condition-case (vec 0 7) ((exn) #f))
     84  #f
     85  (condition-case (str 0 7) ((exn) #f))
    8586  #f
    8687  (callable-data (lst 0 #f))
     
    106107  (callable-data (str (- (callable-length str) 1) -1))
    107108  "543210"
    108   (callable-data (callable-reverse str))
    109   "543210"
    110109  (callable-data (lst 3 1))
    111110  '(3 2)
     
    140139  (callable? #(0 1 2 3))
    141140  #f
     141  (sequence? #(0 1 2 3))
     142  #t
    142143  (callable? "0123")
    143144  #f
    144   (callable? "0123")
    145   #f
    146 )
    147 ;(callables?)
    148 
    149 (define-checks (recursives? verbose?
    150                             pl*
    151                             (make-callable* '(a (b . c)))
    152                             ls*
    153                             (make-callable* '(a (b c)))
    154                             lv*
    155                             (make-callable* '(a #(b c)))
    156                             vp*
    157                             (make-callable* (vector 'a '(b . c)))
    158                             vs*
    159                             (make-callable* (vector 'a "bc"))
    160                             lv**
    161                             (make-callable* '(a (b #(c d) e) f)))
     145  (sequence? "0123")
     146  #t
     147  (sequence? #f)
     148  #f)
     149
     150(define-checks
     151  (flat-operations
     152    verbose?
     153    pls
     154    (make-callable '(0 1 2 3 4 5 . 6))
     155    lst
     156    (make-callable '(0 1 2 3 4 5))
     157    vec
     158    (make-callable #(0 1 2 3 4 5))
     159    str
     160    (make-callable "012345"))
     161  (callable? pls)
     162  #t
     163  (callable? '())
     164  #f
     165  (callable-null? vec)
     166  #f
     167  (callable-null? (callable-nil vec))
     168  #t
     169  (callable-flat? vec)
     170  #t
     171  (callable-data (callable-nil vec))
     172  #()
     173  (callable-nil pls)
     174  6
     175  (callable-data (callable-reverse lst lst))
     176  '(5 4 3 2 1 0 0 1 2 3 4 5)
     177  (callable-data (callable-reverse str str))
     178  "543210012345"
     179  (callable-data (callable-reverse str))
     180  "543210"
     181  (callable-indices even? vec)
     182  '(0 2 4)
     183  (callable-indices odd? pls)
     184  '(1 3 5)
     185  (callable-data (callable-copy lst))
     186  '(0 1 2 3 4 5)
     187  (callable-data (callable-copy vec))
     188  #(0 1 2 3 4 5)
     189  (callable-data (callable-map add1 vec))
     190  #(1 2 3 4 5 6)
     191  (callable-data (callable-map add1 pls))
     192  '(1 2 3 4 5 6 . 6)
     193  (callable-for-each print vec)
     194  (if #f #f)
     195  (callable-data (callable-filter odd? vec))
     196  #(1 3 5)
     197  (receive (yes no) (callable-filter odd? vec) (list (yes) (no)))
     198  '(#(1 3 5) #(0 2 4))
     199  (callable-data (callable-append str str str))
     200  "012345012345012345"
     201  (callable-data (callable-append str str str str))
     202  "012345012345012345012345")
     203
     204(define-checks
     205  (nested-access
     206    verbose?
     207    pl*
     208    (make-callable* '(a (b . c)))
     209    ls*
     210    (make-callable* '(a (b c)))
     211    lv*
     212    (make-callable* '(a #(b c)))
     213    vp*
     214    (make-callable* (vector 'a '(b . c)))
     215    vs*
     216    (make-callable* (vector 'a "bc"))
     217    lv**
     218    (make-callable* '(a (b #(c d) e) f))
     219    ls**
     220    (make-callable* '(a (b (c) d) e))
     221    ns**
     222    (make-callable* '(0 (1 #(2) 3) 4)))
     223  (callable-data* pl*)
     224  '(a (b . c))
     225  (callable-data* lv**)
     226  '(a (b #(c d) e) f)
     227  (callable-data* ns**)
     228  '(0 (1 #(2) 3) 4)
     229  (callable-data* (callable-map* add1 ns**))
     230  '(1 (2 #(3) 4) 5)
    162231  (ls* 0)
    163232  'a
    164233  ((ls* 1) 1)
    165234  'c
    166   (((ls* 1) 2 #f))
     235  (callable-data ((ls* 1) 2 #f))
    167236  '()
     237  (callable? ((ls* 1) 1 2))
     238  #t
     239  (callable-data ((ls* 1) 1 2))
     240  '(c)
     241  (callable? pl*)
     242  #t
     243  (callable-data (pl* 1))
     244  '(b . c)
     245  (callable? (pl* 1))
     246  #t
    168247  ((pl* 1) 0)
    169248  'b
     249  (callable? ((pl* 1) 1 #f))
     250  #t
    170251  (((pl* 1) 1 #f))
    171252  'c
     253  (callable-data ((pl* 1) 1 #f))
     254  'c
    172255  ((lv* 1) 1)
    173256  'c
     257  (callable-data ((lv* 1) 1 2))
     258  #(c)
    174259  ((vp* 1) 0)
    175260  'b
     261  (callable? (vp* 1))
     262  #t
     263  (callable? ((vp* 1) 1 #f))
     264  #t
    176265  (((vp* 1) 1 #f))
     266  'c
     267  (callable-data ((vp* 1) 1 #f))
    177268  'c
    178269  ((vs* 1) 0)
     
    180271  ((vs* 1) 1)
    181272  #\c
    182   (((vs* 1) 2 #f))
     273  (callable-data ((vs* 1) 2 #f))
    183274  ""
    184275  (lv** 0)
     
    193284  'f
    194285  ((lv** 1) 2)
    195   'e
     286  'e)
     287
     288(define-checks
     289  (new-types verbose?)
     290  ((sequence-constructors 'ras)
     291   array?
     292   (lambda (k)
     293     (apply array
     294            (let loop ((i 0) (result '()))
     295              (if (= i k) result (loop (+ i 1) (cons #f result))))))
     296   (lambda (arr k) (array-at k arr))
     297   (lambda (arr k new) (array-update! k new arr))
     298   array-length)
     299  (if #f #f)
     300  (sequence? (make-array))
     301  #t
     302  (set! arr (make-callable (array 0 1 2 3)))
     303  (if #f #f)
     304  (arr 2)
     305  2
     306  (array-equal? (callable-data (arr 1 3)) (array 1 2))
     307  #t
     308  (array-equal? (callable-data (arr 3 #f)) (array 3))
     309  #t
     310  (array-equal? (callable-data (arr 3 1)) (array 3 2))
     311  #t
     312  (set! va* (make-callable* (vector 0 (array 1 2 3))))
     313  (if #f #f)
     314  (set! mva* (callable-map* add1 va*))
     315  (if #f #f)
     316  (mva* 0)
     317  1
     318  ((mva* 1) 0)
     319  2
     320  (array-equal? (callable-data (mva* 1)) (array 2 3 4))
     321  #t
     322  (sequence-constructors)
     323  (if #f #f)
     324  (sequence? (make-array))
     325  #f)
     326
     327(check-all CALLABLE-SEQUENCES
     328  (flat-access)
     329  (flat-operations)
     330  (nested-access)
     331  (new-types)
    196332  )
    197 ;(recursives?)
    198 
    199 (check-all CALLABLES (callables?) (recursives?))
    200 
Note: See TracChangeset for help on using the changeset viewer.