interpretive-schemer/prelude.scm

"Prelude --- Standard Library for interpretive-scheme"
"Copyright © 2018 Alex Vong <alexvong1995@gmail.com>"

"This file is part of interpretive-scheme."

"interpretive-scheme is free software; you can redistribute it and/or modify it"
"under the terms of the GNU General Public License as published by"
"the Free Software Foundation; either version 3 of the License, or (at"
"your option) any later version."

"interpretive-scheme is distributed in the hope that it will be useful, but"
"WITHOUT ANY WARRANTY; without even the implied warranty of"
"MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"
"GNU General Public License for more details."

"You should have received a copy of the GNU General Public License"
"along with interpretive-scheme.  If not, see <http://www.gnu.org/licenses/>."


(define list
  (lambda args
    args))

(define (procedure? x)
  (or (primitive-procedure? x)
      (compound-procedure? x)))

(define (fold op init ls)
  (if (null? ls)
      init
      (fold op
            (op (car ls) init)
            (cdr ls))))

(define %+ +)
(define +
  (lambda nums
    (fold %+ 0 nums)))

(define %- -)
(define -
  (lambda nums
    (let ((first (car nums))
          (rest (cdr nums)))
      (if (null? rest)
          (%- 0 first)
          (%- first (apply + rest))))))

(define %* *)
(define *
  (lambda nums
    (fold %* 1 nums)))

(define (reverse ls)
  (fold cons '() ls))

(define (length ls)
  (fold (lambda (_ n)
          (+ n 1))
        0
        ls))

(define (any pred ls)
  (fold (lambda (x accum)
          (or accum (pred x)))
        #f
        ls))

(define (every pred ls)
  (fold (lambda (x accum)
          (and accum (pred x)))
        #t
        ls))

(define (fold-right op init ls)
  (fold op init (reverse ls)))

(define (not x)
  (if x #f #t))

(define (identity x)
  x)

(define (const x)
  (lambda _ x))

(define (negate proc)
  (lambda args
    (not (apply proc args))))

(define %apply apply)

(define (%compose g f)
  (lambda args
    (g (%apply f args))))

(define compose
  (lambda procs
    (fold-right %compose identity procs)))

(define caar (compose car car))
(define cadr (compose car cdr))
(define cdar (compose cdr car))
(define cddr (compose cdr cdr))
(define caaar (compose car car car))
(define caadr (compose car car cdr))
(define cadar (compose car cdr car))
(define caddr (compose car cdr cdr))
(define cdaar (compose cdr car car))
(define cdadr (compose cdr car cdr))
(define cddar (compose cdr cdr car))
(define cdddr (compose cdr cdr cdr))
(define caaaar (compose car car car car))
(define caaadr (compose car car car cdr))
(define caadar (compose car car cdr car))
(define caaddr (compose car car cdr cdr))
(define cadaar (compose car cdr car car))
(define cadadr (compose car cdr car cdr))
(define caddar (compose car cdr cdr car))
(define cadddr (compose car cdr cdr cdr))
(define cdaaar (compose cdr car car car))
(define cdaadr (compose cdr car car cdr))
(define cdadar (compose cdr car cdr car))
(define cdaddr (compose cdr car cdr cdr))
(define cddaar (compose cdr cdr car car))
(define cddadr (compose cdr cdr car cdr))
(define cdddar (compose cdr cdr cdr car))
(define cddddr (compose cdr cdr cdr cdr))

(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
(define fifth (compose car cddddr))
(define sixth (compose cadr cddddr))
(define eighth (compose cadddr cddddr))
(define ninth (compose car cddddr cddddr))
(define tenth (compose cadr cddddr cddddr))

(define last (compose car reverse))

(define cons*
  (lambda args
    (fold cons
          (last args)
          (cdr (reverse args)))))

(define apply
  (lambda args
    (let ((proc (car args))
          (args* (cdr args)))
      (%apply proc
              (%apply cons* args*)))))

(define (filter pred ls)
  (fold-right (lambda (x accum)
                (if (pred x)
                    (cons x accum)
                    accum))
              '()
              ls))

(define (%map proc ls)
  (fold-right (lambda (x accum)
                (cons (proc x) accum))
              '()
              ls))

(define unfold-right
  (lambda args
    (let ((pred (first args))
          (proc (second args))
          (next (third args))
          (init (fourth args))
          (accum (if (>= (length args) 5) (fifth args) '())))

      (if (> (length args) 5)
          (error "Too many arguments supplied: UNFOLD-RIGHT" args)

          (if (pred init)
              accum
              (unfold-right pred
                            proc
                            next
                            (next init)
                            (cons (proc init) accum)))))))

(define zip
  (lambda ls-of-ls
    (reverse (unfold-right (lambda (ls-of-ls) (any null? ls-of-ls))
                           (lambda (ls-of-ls) (%map car ls-of-ls))
                           (lambda (ls-of-ls) (%map cdr ls-of-ls))
                           ls-of-ls))))

(define map
  (lambda args
    (let ((proc (car args))
          (ls-of-ls (cdr args)))

      (%map (lambda (ls)
              (apply proc ls))
            (apply zip ls-of-ls)))))

(define for-each
  (lambda args
    (let ((proc (car args))
          (ls-of-ls (cdr args)))

      (fold (lambda (ls _)
              (apply proc ls)
              '())
            '()
            (apply zip ls-of-ls)))))

(define (%append ls ls*)
  (fold-right cons ls* ls))

(define append
  (lambda ls-of-ls
    (fold-right %append '() ls-of-ls)))

(define (concatenate ls-of-ls)
  (apply append ls-of-ls))

(define (list? x)
  (cond ((null? x) #t)
        ((pair? x) (list? (cdr x)))
        (else #f)))

(define (%<-> a b)
  (or (and a b)
      (not (or a b))))

(define (%equal? a b)
  (cond ((boolean? a)
         (cond ((boolean? b)
                (%<-> a b))
               ((or (integer? b)
                    (string? b)
                    (symbol? b)
                    (null? b)
                    (pair? b)
                    (eof-object? b))
                #f)
               (else
                (error "Unknown value type: EQUAL?" b))))

        ((integer? a)
         (cond ((integer? b)
                (= a b))
               ((or (boolean? b)
                    (string? b)
                    (symbol? b)
                    (null? b)
                    (pair? b)
                    (eof-object? b))
                #f)
               (else
                (error "Unknown value type: EQUAL?" b))))

        ((string? a)
         (cond ((string? b)
                (string=? a b))
               ((or (boolean? b)
                    (integer? b)
                    (symbol? b)
                    (null? b)
                    (pair? b)
                    (eof-object? b))
                #f)
               (else
                (error "Unknown value type: EQUAL?" b))))

        ((symbol? a)
         (cond ((symbol? b)
                (string=? (symbol->string a)
                          (symbol->string b)))
               ((or (boolean? b)
                    (integer? b)
                    (string? b)
                    (null? b)
                    (pair? b)
                    (eof-object? b))
                #f)
               (else
                (error "Unknown value type: EQUAL?" b))))

        ((null? a)
         (cond ((null? b)
                #t)
               ((or (boolean? b)
                    (integer? b)
                    (string? b)
                    (symbol? b)
                    (pair? b)
                    (eof-object? b))
                #f)
               (else
                (error "Unknown value type: EQUAL?" b))))

        ((pair? a)
         (cond ((pair? b)
                (and (%equal? (car a) (car b))
                     (%equal? (cdr a) (cdr b))))
               ((or (boolean? b)
                    (integer? b)
                    (string? b)
                    (symbol? b)
                    (null? b)
                    (eof-object? b))
                #f)
               (else
                (error "Unknown value type: EQUAL?" b))))

        ((eof-object? a)
         (cond ((eof-object? b)
                #t)
               ((or (boolean? b)
                    (integer? b)
                    (string? b)
                    (symbol? b)
                    (null? b)
                    (pair? b))
                #f)
               (else
                (error "Unknown value type: EQUAL?" b))))

        (else
         (error "Unknown value type: EQUAL?" a))))

(define equal?
  (lambda args
    (if (null? args)
        #t
        (let ((first (car args))
              (rest (cdr args)))
          (every (lambda (x)
                   (%equal? x first))
                 rest)))))

(define (expt a b)
  (if (>= b 0)
      (apply * (make-list b a))
      (error "Negative power: EXPT" b)))

(define (%max a b)
  (if (> a b) a b))

(define max
  (lambda nums
    (fold %max
          (car nums)
          (cdr nums))))

(define (%min a b)
  (if (< a b) a b))

(define min
  (lambda nums
    (fold %min
          (car nums)
          (cdr nums))))

(define (zero? x)
  (= x 0))

(define (positive? x)
  (> x 0))

(define (negative? x)
  (< x 0))

(define (%/ a b)
  (if (zero? (remainder a b))
      (quotient a b)
      (error "Not divisible: /" a b)))

(define /
  (lambda nums
    (let ((first (car nums))
          (rest (cdr nums)))
      (if (null? rest)
          (%/ 1 first)
          (%/ first (apply * rest))))))

(define (abs x)
  (if (negative? x)
      (- x)
      x))

(define (modulo a b)
  (let ((r (remainder a b)))
    (if (or (< (abs r) (abs b))
            (and (>= a 0) (>= b 0))
            (and (negative? a) (negative? b)))
        r
        (+ r b))))

(define (even? n)
  (zero? (modulo n 2)))

(define odd? (negate even?))

(define make-list
  (lambda args
    (let ((n (first args))
          (init (if (>= (length args) 2) (second args) '())))

      (if (> (length args) 2)
          (error "Too many arguments supplied: MAKE-LIST" args)

          (unfold-right zero?
                        (const init)
                        (lambda (n) (- n 1))
                        n)))))

(define (list-ref ls k)
  (let ((kth-cdr (apply compose
                        (make-list k cdr))))
    (car (kth-cdr ls))))

(define iota
  (lambda args
    (let ((count (first args))
          (start (if (>= (length args) 2) (second args) 0))
          (step (if (>= (length args) 3) (third args) 1)))

      (if (> (length args) 3)
          (error "Too many arguments supplied: IOTA" args)

          (unfold-right (lambda (n) (< n start))
                        identity
                        (lambda (n) (- n step))
                        (+ start
                           (* (- count 1)
                              step)))))))

'
(define fold*
  (lambda args
    (let ((op (car args))
          (init (cadr args))
          (ls-of-ls (cddr args)))
      (if (null? ls)
          init
          (fold op
                (apply op (car ls) init)
                (cdr ls))))))