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-map
  17   (lambda (proc . strings)
  18                                         ; result length is min of arg lengths
  19     (let* ((l (apply min (map string-length strings)))
  20                                         ; create the result
  21            (s (make-string l)))
  22                                         ; walk the strings, doing evaluation
  23       (define (_m p)
  24         (if (equal? p l)
  25             s
  26             (begin
  27               (string-set! s p (apply proc (map (lambda (s) (string-ref s p)) strings)))
  28               (_m (+ p 1))
  29               )
  30             )
  31         )
  32       (_m 0)
  33       )
  34     )
  35   )
  36
  37 (_??_ (string-map (lambda (x) (+ 1 x)) "HAL") "IBM")
  38
  39 (define string-copy!
  40   (lambda (t a f . args)
  41     (let ((l 0)
  42           (h (string-length f))
  43           (o a)
  44           (d 1))
  45                                         ; handle optional start/end args
  46
  47       (if (not (null? args))
  48           (begin
  49             (set! l (car args))
  50             (if (not (null? (cdr args)))
  51                 (set! h (cadr args)))
  52             (set! o (- a l))
  53             )
  54           )
  55                                         ; flip copy order if dst is
  56                                         ; after src
  57       (if (< l a)
  58           (begin
  59             (set! d h)
  60             (set! h (- l 1))
  61             (set! l (- d 1))
  62             (set! d -1)
  63             )
  64           )
  65                                         ; loop copying one at a time
  66       (do ((p l (+ p d))
  67            )
  68           ((= p h) t)
  69         (string-set! t (+ p o) (string-ref f p))
  70         )
  71       )
  72     )
  73   )
  74
  75 (_??_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ")
  76 (_??_ (string-copy! (make-string 10) 1 "hello" 0 5) " hello    ")
  77 (_??_ (string-copy! (make-string 10) 0 "hello" 0 5) "hello     ")
  78
  79 (define (string-upcase s) (string-map char-upcase s))
  80 (define (string-downcase s) (string-map char-downcase s))
  81 (define string-foldcase string-downcase)
  82
  83 (define string-copy
  84   (lambda (s . args)
  85     (let ((l 0)
  86           (h (string-length s)))
  87       (if (not (null? args))
  88           (begin
  89             (set! l (car args))
  90             (if (not (null? (cdr args)))
  91                 (set! h (cadr args)))
  92             )
  93           )
  94       (string-copy! (make-string (- h l)) 0 s l h)
  95       )
  96     )
  97   )
  98
  99 (_??_ (string-copy "hello" 0 1) "h")
 100 (_??_ (string-copy "hello" 1) "ello")
 101 (_??_ (string-copy "hello") "hello")
 102
 103 (define substring string-copy)
 104
 105 (define string-fill!
 106   (lambda (s a . args)
 107     (let ((l 0)
 108           (h (string-length s)))
 109       (cond ((not (null? args))
 110              (set! l (car args))
 111              (cond ((not (null? (cdr args)))
 112                     (set! h (cadr args)))
 113                    )
 114              )
 115             )
 116       (define (_f b)
 117         (cond ((< b h)
 118                (string-set! s b a)
 119                (_f (+ b 1))
 120                )
 121               (else s)
 122               )
 123         )
 124       (_f l)
 125       )
 126     )
 127   )
 128
 129 (_??_ (string-fill! (make-string 10) #\a) "aaaaaaaaaa")
 130 (_??_ (string-fill! (make-string 10) #\a 1 2) " a        ")
 131
 132 (define string-for-each
 133   (lambda (proc . strings)
 134                                         ; result length is min of arg lengths
 135     (let* ((l (apply min (map string-length strings)))
 136            )
 137                                         ; walk the strings, doing evaluation
 138       (define (_m p)
 139         (if (equal? p l)
 140             #t
 141             (begin
 142               (apply proc (map (lambda (s) (string-ref s p)) strings))
 143               (_m (+ p 1))
 144               )
 145             )
 146         )
 147       (_m 0)
 148       )
 149     )
 150   )
 151
 152 (_??_ (string-for-each write-char "IBM\n") #t)