git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_string.scheme

   1 ;
   2 ; Copyright © 2018 Keith Packard <keithp@keithp.com>
   3 ;
   4 ; This program is free software; you can redistribute it and/or modify
   5 ; it under the terms of the GNU General Public License as published by
   6 ; the Free Software Foundation, either version 2 of the License, or
   7 ; (at your option) any later version.
   8 ;
   9 ; This program is distributed in the hope that it will be useful, but
  10 ; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ; General Public License for more details.
  13 ;
  14 ; string functions placed in ROM
  15
  16 (define string (lambda chars (list->string chars)))
  17
  18 (_??_ (string #\a #\b #\c) "abc")
  19
  20 (define string-map
  21   (lambda (proc . strings)
  22                                         ; result length is min of arg lengths
  23     (let* ((l (apply min (map string-length strings)))
  24                                         ; create the result
  25            (s (make-string l)))
  26                                         ; walk the strings, doing evaluation
  27       (define (_m p)
  28         (if (equal? p l)
  29             s
  30             (begin
  31               (string-set! s p (apply proc (map (lambda (s) (string-ref s p)) strings)))
  32               (_m (+ p 1))
  33               )
  34             )
  35         )
  36       (_m 0)
  37       )
  38     )
  39   )
  40
  41 (_??_ (string-map (lambda (x) (+ 1 x)) "HAL") "IBM")
  42
  43 (define string-copy!
  44   (lambda (t a f . args)
  45     (let ((l 0)
  46           (h (string-length f))
  47           (o a)
  48           (d 1))
  49                                         ; handle optional start/end args
  50
  51       (if (not (null? args))
  52           (begin
  53             (set! l (car args))
  54             (if (not (null? (cdr args)))
  55                 (set! h (cadr args)))
  56             (set! o (- a l))
  57             )
  58           )
  59                                         ; flip copy order if dst is
  60                                         ; after src
  61       (if (< l a)
  62           (begin
  63             (set! d h)
  64             (set! h (- l 1))
  65             (set! l (- d 1))
  66             (set! d -1)
  67             )
  68           )
  69                                         ; loop copying one at a time
  70       (do ((p l (+ p d))
  71            )
  72           ((= p h) t)
  73         (string-set! t (+ p o) (string-ref f p))
  74         )
  75       )
  76     )
  77   )
  78
  79 (_??_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ")
  80 (_??_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello    ")
  81 (_??_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ")
  82
  83 (define (string-upcase s) (string-map char-upcase s))
  84 (define (string-downcase s) (string-map char-downcase s))
  85 (define string-foldcase string-downcase)
  86
  87 (define string-copy
  88   (lambda (s . args)
  89     (let ((l 0)
  90           (h (string-length s)))
  91       (if (not (null? args))
  92           (begin
  93             (set! l (car args))
  94             (if (not (null? (cdr args)))
  95                 (set! h (cadr args)))
  96             )
  97           )
  98       (string-copy! (make-string (- h l)) 0 s l h)
  99       )
 100     )
 101   )
 102
 103 (_??_ (string-copy "hello" 0 1) "h")
 104 (_??_ (string-copy "hello" 1) "ello")
 105 (_??_ (string-copy "hello") "hello")
 106
 107 (define substring string-copy)
 108
 109 (define string-fill!
 110   (lambda (s a . args)
 111     (let ((l 0)
 112           (h (string-length s)))
 113       (cond ((not (null? args))
 114              (set! l (car args))
 115              (cond ((not (null? (cdr args)))
 116                     (set! h (cadr args)))
 117                    )
 118              )
 119             )
 120       (define (_f b)
 121         (cond ((< b h)
 122                (string-set! s b a)
 123                (_f (+ b 1))
 124                )
 125               (else s)
 126               )
 127         )
 128       (_f l)
 129       )
 130     )
 131   )
 132
 133 (_??_ (string-fill! (make-string 10) #\a) "aaaaaaaaaa")
 134 (_??_ (string-fill! (make-string 10) #\a 1 2) " a        ")
 135
 136 (define string-for-each
 137   (lambda (proc . strings)
 138                                         ; result length is min of arg lengths
 139     (let* ((l (apply min (map string-length strings)))
 140            )
 141                                         ; walk the strings, doing evaluation
 142       (define (_m p)
 143         (if (equal? p l)
 144             #t
 145             (begin
 146               (apply proc (map (lambda (s) (string-ref s p)) strings))
 147               (_m (+ p 1))
 148               )
 149             )
 150         )
 151       (_m 0)
 152       )
 153     )
 154   )
 155
 156 (_??_ (string-for-each write-char "IBM\n") #t)