src/scm/support-code.scm

   1 ;;; support-code.scm
   2 ;;; Part of the initial environment that you will need to provide with your
   3 ;;; compiler, but written in [very elementary] Scheme. Put otherwise, your
   4 ;;; compiler will have to be able to compile this code in order to provide it.
   5
   6 ;;; Programmer: Mayer Goldberg, 2009
   7
   8 ;;; (define binary-add #f)
   9 ;;; (define binary-sub #f)
  10 ;;; (define binary-mul #f)
  11 ;;; (define binary-div #f)
  12 ;;; (define binary<? #f)
  13 ;;; (define binary=? #f)
  14 ;;;
  15 ;;; (let ((+ +) (- -) (* *) (/ /) (< <) (= =))
  16 ;;;   (set! binary-add (lambda (a b) (+ a b)))
  17 ;;;   (set! binary-sub (lambda (a b) (- a b)))
  18 ;;;   (set! binary-mul (lambda (a b) (* a b)))
  19 ;;;   (set! binary-div (lambda (a b) (/ a b)))
  20 ;;;   (set! binary<? (lambda (a b) (< a b)))
  21 ;;;   (set! binary=? (lambda (a b) (= a b))))
  22
  23 (define foldr
  24   (lambda (binop final s)
  25     (letrec ((loop (lambda (s)
  26                      (if (null? s)
  27                          final
  28                          (binop (car s) (loop (cdr s)))))))
  29       (loop s))))
  30
  31 (define add1 (lambda (n) (binary-add n 1)))
  32 (define sub1 (lambda (n) (binary-sub n 1)))
  33
  34 (define order
  35   (lambda (<)
  36     (letrec ((loop
  37               (lambda (a s)
  38                 (or (null? s)
  39                     (and (< a (car s))
  40                          (loop (car s) (cdr s)))))))
  41       (lambda (a . s)
  42         (loop a s)))))
  43
  44 (define < (order binary<?))
  45
  46 (define <=
  47   (let ((binary<=?
  48          (lambda (a b)
  49            (or (binary<? a b)
  50                (binary=? a b)))))
  51     (order binary<=?)))
  52
  53 (define >
  54   (let ((binary>?
  55          (lambda (a b)
  56            (binary<? b a))))
  57     (order binary>?)))
  58
  59 (define >=
  60   (let ((binary>=?
  61          (lambda (a b)
  62            (or (binary=? a b)
  63                (binary>? a b)))))
  64     (order binary>=?)))
  65
  66 (define = (order binary=?))
  67
  68 ;;; extension: a variadic not-equal
  69 (define <>
  70   (letrec ((loop
  71             (lambda (a s)
  72               (or (null? s)
  73                   (and (andmap (lambda (b) (not (= a b))) s)
  74                        (loop (car s) (cdr s)))))))
  75     (lambda s
  76       (loop (car s) (cdr s)))))
  77
  78 (define not (lambda (x) (if x #f #t)))
  79
  80 (define compose
  81   (let ((binary-compose
  82          (lambda (f g)
  83            (lambda (x)
  84              (f (g x))))))
  85     (lambda s
  86       (foldr binary-compose (lambda (x) x) s))))
  87
  88 (define caar (compose car car))
  89 (define cadr (compose car cdr))
  90 (define cdar (compose cdr car))
  91 (define cddr (compose cdr cdr))
  92 (define caaar (compose car caar))
  93 (define caadr (compose car cadr))
  94 (define cadar (compose car cdar))
  95 (define caddr (compose car cddr))
  96 (define cdaar (compose cdr caar))
  97 (define cdadr (compose cdr cadr))
  98 (define cddar (compose cdr cdar))
  99 (define cdddr (compose cdr cddr))
 100 (define caaaar (compose car caaar))
 101 (define caaadr (compose car caadr))
 102 (define caadar (compose car cadar))
 103 (define caaddr (compose car caddr))
 104 (define cadaar (compose car cdaar))
 105 (define cadadr (compose car cdadr))
 106 (define caddar (compose car cddar))
 107 (define cadddr (compose car cdddr))
 108 (define cdaaar (compose cdr caaar))
 109 (define cdaadr (compose cdr caadr))
 110 (define cdadar (compose cdr cadar))
 111 (define cdaddr (compose cdr caddr))
 112 (define cddaar (compose cdr cdaar))
 113 (define cddadr (compose cdr cdadr))
 114 (define cdddar (compose cdr cddar))
 115 (define cddddr (compose cdr cdddr))
 116
 117 (define ^variadic-right-from-binary
 118   (lambda (binary-op base-value)
 119     (letrec ((op-list
 120               (lambda (s)
 121                 (if (null? s) base-value
 122                     (binary-op (car s) (op-list (cdr s)))))))
 123       (lambda args
 124         (op-list args)))))
 125
 126 (define ^variadic-left-from-binary
 127   (lambda (binary-op base-value)
 128     (letrec ((op-list
 129               (lambda (acc s)
 130                 (if (null? s) acc
 131                     (op-list (binary-op acc (car s)) (cdr s))))))
 132       (lambda args
 133         (if (null? args) base-value
 134             (op-list (car args) (cdr args)))))))
 135
 136 (define + (^variadic-right-from-binary binary-add 0))
 137 (define * (^variadic-right-from-binary binary-mul 1))
 138
 139 (define - (^variadic-left-from-binary binary-sub 0))
 140 (define / (^variadic-left-from-binary binary-div 1))
 141
 142 (define ^char-op
 143   (lambda (int-op)
 144     (lambda (ch1 ch2)
 145       (int-op (char->integer ch1) (char->integer ch2)))))
 146
 147 (define char<=? (order (^char-op <=)))
 148 (define char<? (order (^char-op <)))
 149 (define char>=? (order (^char-op >=)))
 150 (define char>? (order (^char-op >)))
 151
 152 (define char-uppercase?
 153   (lambda (ch)
 154     (and (char<=? #\A ch)
 155          (char<=? ch #\Z))))
 156
 157 (define char-lowercase?
 158   (lambda (ch)
 159     (and (char<=? #\a ch)
 160          (char<=? ch #\z))))
 161
 162 (define char-upcase
 163   (let ((char-aA (- (char->integer #\a) (char->integer #\A))))
 164     (lambda (ch)
 165       (if (char-lowercase? ch)
 166               (integer->char
 167                 (- (integer->char ch) char-aA))
 168           ch))))
 169
 170 (define char-downcase
 171   (let ((char-aA (- (char->integer #\a) (char->integer #\A))))
 172     (lambda (ch)
 173       (if (char-uppercase? ch)
 174               (integer->char
 175                 (+ (integer->char ch) char-aA))
 176           ch))))
 177
 178 (define char-ci<=?
 179   (order
 180    (lambda (ch1 ch2)
 181      (char<=? (char-upcase ch1) (char-upcase ch2)))))
 182
 183 (define char-ci<?
 184   (order
 185    (lambda (ch1 ch2)
 186      (char<? (char-upcase ch1) (char-upcase ch2)))))
 187
 188 (define char-ci=?
 189   (order
 190    (lambda (ch1 ch2)
 191      (char=? (char-upcase ch1) (char-upcase ch2)))))
 192
 193 (define char-ci>?
 194   (order
 195    (lambda (ch1 ch2)
 196      (char>? (char-upcase ch1) (char-upcase ch2)))))
 197
 198 (define char-ci>=?
 199   (order
 200    (lambda (ch1 ch2)
 201      (char>=? (char-upcase ch1) (char-upcase ch2)))))
 202
 203 (define string-upcase
 204   (lambda (string)
 205     (list->string
 206      (map char-upcase (string->list string)))))
 207
 208 (define string-downcase
 209   (lambda (string)
 210     (list->string
 211      (map char-downcase (string->list string)))))
 212
 213 (define even?
 214   (lambda (n)
 215     (zero? (remainder n 2))))
 216
 217 (define odd?
 218   (lambda (n)
 219     (not (zero? (remainder n 2)))))
 220
 221 (define length
 222   (lambda (s)
 223     (if (null? s) 0
 224         (add1 (length (cdr s))))))
 225
 226 (define list (lambda args args))
 227
 228 (define list-ref
 229   (lambda (s i)
 230     (if (zero? i) (car s)
 231         (list-ref (cdr s) (- i 1)))))
 232
 233 (define list?
 234   (lambda (e)
 235     (or (null? e)
 236         (and (pair? e)
 237              (list? (cdr e))))))
 238
 239 (define map
 240   (letrec ((map-list
 241             (lambda (f lists)
 242               (if (null? (car lists)) '()
 243                   (cons (apply f (map-one car lists))
 244                         (map-list f (map-one cdr lists))))))
 245            (map-one
 246             (lambda (f s)
 247               (if (null? s) '()
 248                   (cons (f (car s))
 249                         (map-one f (cdr s)))))))
 250     (lambda (f . args)
 251       (map-list f args))))
 252
 253 (define member?
 254   (lambda (a s)
 255     (ormap (lambda (b) (eq? a b)) s)))
 256
 257 (define negative? (lambda (n) (< n 0)))
 258
 259 (define positive? (lambda (n) (> n 0)))
 260
 261 (define zero? (lambda (x) (= x 0)))
 262
 263 (define vector (lambda args (list->vector args)))
 264
 265 (define ormap
 266   (lambda (f s)
 267     (and (pair? s)
 268          (or (f (car s))
 269              (ormap f (cdr s))))))
 270
 271 (define andmap
 272   (lambda (f s)
 273     (or (null? s)
 274         (and (f (car s))
 275              (andmap f (cdr s))))))
 276
 277 (define string->list
 278   (letrec ((loop
 279             (lambda (str n s)
 280               (if (= n -1) s
 281                   (loop str
 282                         (- n 1)
 283                         (cons (string-ref str n) s))))))
 284     (lambda (str)
 285       (loop str (- (string-length str) 1) '()))))
 286
 287 (define vector->list
 288   (letrec ((loop
 289             (lambda (v n s)
 290               (if (= n -1) s
 291                   (loop v
 292                         (- n 1)
 293                         (cons (vector-ref v n) s))))))
 294     (lambda (v)
 295       (loop v (- (vector-length v) 1) '()))))
 296
 297 (define list->string
 298   (lambda (s)
 299     (let* ((n (length s))
 300            (str (make-string n)))
 301       (letrec ((loop
 302                 (lambda (s i)
 303                   (if (= i n) str
 304                       (begin
 305                         (string-set! str i (car s))
 306                         (loop (cdr s) (+ i 1)))))))
 307         (loop s 0)))))
 308
 309 (define list->vector
 310   (lambda (s)
 311     (let* ((n (length s))
 312            (v (make-vector n)))
 313       (letrec ((loop
 314                 (lambda (s i)
 315                   (if (= i n) v
 316                       (begin
 317                         (vector-set! v i (car s))
 318                         (loop (cdr s) (+ i 1)))))))
 319         (loop s 0)))))
 320
 321 (define member
 322   (lambda (a s)
 323     (cond ((null? s) #f)
 324           ((eq? (car s) a) s)
 325           (else (member a (cdr s))))))
 326
 327 (define assoc
 328   (lambda (a s)
 329     (cond ((null? s) #f)
 330           ((eq? (caar s) a) (car s))
 331           (else (assoc a (cdr s))))))
 332
 333 (define equal?
 334   (lambda (e1 e2)
 335     (cond ((and (pair? e1) (pair? e2))
 336            (and (equal? (car e1) (car e2))
 337                 (equal? (cdr e1) (cdr e2))))
 338           ((and (vector? e1) (vector? e2)
 339                 (= (vector-length e1) (vector-length e2)))
 340            (equal? (vector->list e1) (vector->list e2)))
 341           ((and (null? e1) (null? e2)) #t)
 342           ((and (boolean? e1) (boolean? e2)) (and e1 e2))
 343           ((and (char? e1) (char? e2))
 344            (char=? e1 e2))
 345           ((and (number? e1) (number? e2))
 346            (= e1 e2))
 347           ((and (string? e1) (string? e2))
 348            (string=? e1 e2))
 349           ((and (symbol? e1) (symbol? e2))
 350            (eq? e1 e2))
 351           ((and (void? e1) (void? e2)) #t)
 352           (else #f))))
 353
 354 (define void
 355   (let ((void-object
 356          (if #f #f)))
 357     (lambda () void-object)))
 358
 359 (define void?
 360   (let ((void-object (void)))
 361     (lambda (x) (eq? x void-object))))
 362
 363 (define string-append
 364   (lambda s
 365     (list->string (apply append (map string->list s)))))
 366
 367 (define vector-append
 368   (lambda s
 369     (list->vector (apply append (map vector->list s)))))
 370
 371 (define append
 372   (letrec ((binary-append
 373             (lambda (s1 s2)
 374               (if (null? s1) s2
 375                   (cons (car s1) (binary-append (cdr s1) s2))))))
 376     (lambda s
 377       (foldr binary-append '() s))))
 378
 379 (define reverse
 380   (letrec ((loop
 381             (lambda (s r)
 382               (if (null? s) r
 383                   (loop (cdr s) (cons (car s) r))))))
 384     (lambda (s)
 385       (loop s '()))))
 386
 387 (define string-reverse
 388   (compose
 389    list->string
 390    reverse
 391    string->list))
 392
 393 (define list-ref
 394   (lambda (s i)
 395     (if (zero? i) (car s)
 396         (list-ref (cdr s) (- i 1)))))
 397
 398 (define list-set!
 399   (lambda (s i x)
 400     (if (zero? i) (set-car! s x)
 401         (list-set! (cdr s) (- i 1) x))))
 402
 403 (define max
 404   (let ((binary-max (lambda (a b) (if (> a b) a b))))
 405     (lambda (a . s)
 406       (foldr binary-max a s))))
 407
 408 (define min
 409   (let ((binary-min (lambda (a b) (if (< a b) a b))))
 410     (lambda (a . s)
 411       (foldr binary-min a s))))
 412
 413 (define gcd
 414   (letrec ((binary-gcd
 415             (lambda (a b)
 416               (if (zero? b) a
 417                   (let ((r (remainder a b)))
 418                     (if (zero? r) b
 419                         (binary-gcd b r)))))))
 420     (lambda (a . s)
 421       (foldr binary-gcd a s))))
 422
 423 (define lcm
 424   (lambda s
 425     (/ (apply * s)
 426        (apply gcd s))))
 427
 428 ;(define box
 429 ;  (lambda (x)
 430 ;    (let ((v (make-vector 1)))
 431 ;      (vector-set! v 0 x)
 432 ;      v)))