altos/lambdakey-v1.0: Get this building again

[fw/altos] / src / lambdakey-v1.0 / ao_lambdakey_const.scheme

;
; Copyright © 2016 Keith Packard <keithp@keithp.com>
;
; This program 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 2 of the License, or
; (at your option) any later version.
;
; This program 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.
;
; Lisp code placed in ROM

                                        ; return a list containing all of the arguments
(def (quote list) (lambda l l))

(def (quote def!)
     (macro (a b)
            (list
             def
             (list quote a)
             b)
            )
     )

(begin
 (def! append
   (lambda args
          (def! a-l
            (lambda (a b)
              (cond ((null? a) b)
                    (else (cons (car a) (a-l (cdr a) b)))
                    )
              )
            )
            
          (def! a-ls
            (lambda (l)
              (cond ((null? l) l)
                    ((null? (cdr l)) (car l))
                    (else (a-l (car l) (a-ls (cdr l))))
                    )
              )
            )
          (a-ls args)
          )
   )
 'append)

(append '(a b c) '(d e f) '(g h i))

                                        ;
                                        ; Define a variable without returning the value
                                        ; Useful when defining functions to avoid
                                        ; having lots of output generated.
                                        ;
                                        ; Also accepts the alternate
                                        ; form for defining lambdas of
                                        ; (define (name a y z) sexprs ...) 
                                        ;

(begin
 (def (quote define)
   (macro (a . b)
                                        ; check for alternate lambda definition form

          (cond ((list? a)
                 (set! b
                       (cons lambda (cons (cdr a) b)))
                 (set! a (car a))
                 )
                (else
                 (set! b (car b))
                 )
                )
          (cons begin
                (cons
                 (cons def
                       (cons (cons quote (cons a '()))
                             (cons b '())
                             )
                       )
                 (cons
                  (cons quote (cons a '()))
                  '())
                 )
                )
          )
   )
 'define
 )

                                        ; basic list accessors

(define (caar l) (car (car l)))

(define (cadr l) (car (cdr l)))

(define (cdar l) (cdr (car l)))

(define (caddr l) (car (cdr (cdr l))))

                                        ; (if <condition> <if-true>)
                                        ; (if <condition> <if-true> <if-false)

(define if
  (macro (test . args)
    (cond ((null? (cdr args))
           (list cond (list test (car args)))
                )
          (else
           (list cond
                 (list test (car args))
                 (list 'else (cadr args))
                 )
           )
          )
    )
  )

(if (> 3 2) 'yes)
(if (> 3 2) 'yes 'no)
(if (> 2 3) 'no 'yes)
(if (> 2 3) 'no)

                                        ; simple math operators

(define zero? (macro (value) (list eqv? value 0)))

(zero? 1)
(zero? 0)
(zero? "hello")

(define positive? (macro (value) (list > value 0)))

(positive? 12)
(positive? -12)

(define negative? (macro (value) (list < value 0)))

(negative? 12)
(negative? -12)

(define (abs a) (if (>= a 0) a (- a)))

(abs 12)
(abs -12)

(define max (lambda (a . b)
                   (while (not (null? b))
                     (cond ((< a (car b))
                            (set! a (car b)))
                           )
                     (set! b (cdr b))
                     )
                   a)
  )

(max 1 2 3)
(max 3 2 1)

(define min (lambda (a . b)
                   (while (not (null? b))
                     (cond ((> a (car b))
                            (set! a (car b)))
                           )
                     (set! b (cdr b))
                     )
                   a)
  )

(min 1 2 3)
(min 3 2 1)

(define (even? a) (zero? (% a 2)))

(even? 2)
(even? -2)
(even? 3)
(even? -1)

(define (odd? a) (not (even? a)))

(odd? 2)
(odd? -2)
(odd? 3)
(odd? -1)


(define (list-tail a b)
  (if (zero? b)
      a
    (list-tail (cdr a (- b 1)))
    )
  )

(define (list-ref a b)
  (car (list-tail a b))
  )

(define (list-tail a b)
  (if (zero? b)
      a
    (list-tail (cdr a) (- b 1))))

(list-tail '(1 2 3) 2)

(define (list-ref a b) (car (list-tail a b)))

(list-ref '(1 2 3) 2)
    

                                        ; define a set of local
                                        ; variables one at a time and
                                        ; then evaluate a list of
                                        ; sexprs
                                        ;
                                        ; (let* (var-defines) sexprs)
                                        ;
                                        ; where var-defines are either
                                        ;
                                        ; (name value)
                                        ;
                                        ; or
                                        ;
                                        ; (name)
                                        ;
                                        ; e.g.
                                        ;
                                        ; (let* ((x 1) (y)) (set! y (+ x 1)) y)

(define let*
  (macro (a . b)

                                        ;
                                        ; make the list of names in the let
                                        ;

         (define (_n a)
           (cond ((not (null? a))
                  (cons (car (car a))
                        (_n (cdr a))))
                 (else ())
                 )
           )

                                        ; the set of expressions is
                                        ; the list of set expressions
                                        ; pre-pended to the
                                        ; expressions to evaluate

         (define (_v a b)
           (cond ((null? a) b)           (else
                  (cons
                   (list set
                         (list quote
                               (car (car a))
                               )
                         (cond ((null? (cdr (car a))) ())
                               (else (cadr (car a))))
                         )
                   (_v (cdr a) b)
                   )
                  )
                 )
           )

                                        ; the parameters to the lambda is a list
                                        ; of nils of the right length

         (define (_z a)
           (cond ((null? a) ())
                 (else (cons () (_z (cdr a))))
                 )
           )
                                        ; build the lambda.

         (cons (cons lambda (cons (_n a) (_v a b))) (_z a))
         )
     )

(let* ((a 1) (y a)) (+ a y))

(define let let*)
                                        ; recursive equality

(define (equal? a b)
  (cond ((eq? a b) #t)
        ((pair? a)
         (cond ((pair? b)
                (cond ((equal? (car a) (car b))
                       (equal? (cdr a) (cdr b)))
                      )
                )
               )
         )
        )
  )

(equal? '(a b c) '(a b c))
(equal? '(a b c) '(a b b))

(define member (lambda (obj a . test?)
                      (cond ((null? a)
                             #f
                             )
                            (else
                             (if (null? test?) (set! test? equal?) (set! test? (car test?)))
                             (if (test? obj (car a))
                                 a
                               (member obj (cdr a) test?))
                             )
                            )
                      )
  )

(member '(2) '((1) (2) (3)))

(member '(4) '((1) (2) (3)))

(define (memq obj a) (member obj a eq?))

(memq 2 '(1 2 3))

(memq 4 '(1 2 3))

(memq '(2) '((1) (2) (3)))

(define (_assoc a b t?)
  (if (null? b)
      #f
    (if (t? a (caar b))
        (car b)
      (_assoc a (cdr b) t?)
      )
    )
  )

(define (assq a b) (_assoc a b eq?))
(define (assoc a b) (_assoc a b equal?))

(assq 'a '((a 1) (b 2) (c 3)))
(assoc '(c) '((a 1) (b 2) ((c) 3)))

(define string (lambda a (list->string a)))

(display "apply\n")
(apply cons '(a b))

(define map
  (lambda (a . b)
         (define (args b)
           (cond ((null? b) ())
                 (else
                  (cons (caar b) (args (cdr b)))
                  )
                 )
           )
         (define (next b)
           (cond ((null? b) ())
                 (else
                  (cons (cdr (car b)) (next (cdr b)))
                  )
                 )
           )
         (define (domap b)
           (cond ((null? (car b)) ())
                 (else
                  (cons (apply a (args b)) (domap (next b)))
                  )
                 )
           )
         (domap b)
         )
  )

(map cadr '((a b) (d e) (g h)))

(define for-each (lambda (a . b)
                        (apply map a b)
                        #t))

(for-each display '("hello" " " "world" "\n"))

(define (newline) (write-char #\newline))

(newline)