UNSLISP/miniscm/init.scm

; This is a init file for Mini-Scheme.
; Copyright (C) 2024 Peter McGoron
;
; 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, version 3 of the License.
;
; 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.
;
; You should have received a copy of the GNU General Public License
; along with this program.  If not, see <https://www.gnu.org/licenses/>.

(define modulo remainder)

(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
(define (caddr x) (car (cdr (cdr x))))
(define (cdaar x) (cdr (car (car x))))
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))

(define (list . x) x)

(define (map proc list)
    (if (pair? list)
        (cons (proc (car list)) (map proc (cdr list)))))

(define (for-each proc list)
    (if (pair? list)
        (begin (proc (car list)) (for-each proc (cdr list)))
        #t ))

(define (list-tail x k)
    (if (zero? k)
        x
        (list-tail (cdr x) (- k 1))))

(define (list-ref x k)
    (car (list-tail x k)))

(define list-set!
  (lambda (lst k obj)
    (if (= k 0)
        (set-car! lst obj)
        (list-set! (cdr lst) (- k 1) obj))))

(define (last-pair x)
    (if (pair? (cdr x))
        (last-pair (cdr x))
        x))

(define vector list)
(define vector-ref list-ref)
(define vector-set! list-set!)

(define make-vector
  (lambda (num)
    (letrec
        ((loop
          (lambda (iter cell)
            (if (= iter 0)
                cell
                (loop (- iter 1) (cons #f cell))))))
      (loop num '()))))

(define (head stream) (car stream))

(define (tail stream) (force (cdr stream)))

(define (eof-object? x) (eq? x #f))

;;;;; following part is written by a.k

;;;;	atom?
(define (atom? x)
  (not (pair? x)))

;;;;	memq
(define (memq obj lst)
  (cond
    ((null? lst) #f)
    ((eq? obj (car lst)) lst)
    (else (memq obj (cdr lst)))))

;;;;    equal?
(define (equal? x y)
  (if (pair? x)
    (and (pair? y)
         (equal? (car x) (car y))
         (equal? (cdr x) (cdr y)))
    (and (not (pair? y))
         (eqv? x y))))

;;; Emulation of mutable strings.

(define mutable-string-ref list-ref)
(define mutable-string-set! list-set!)
(define mutable-string list)
(define (mutable-string->list x) x)

(define list<=>
  (lambda (x y <=>)
    (cond
      ((and (null? x) (null? y)) '=)
      ((null? x) '<)
      ((null? y) '>)
      (else
       (let ((dir (<=> (car x) (car y))))
         (if (eq? dir '=)
             (list<=> (cdr x) (cdr y) <=>)
             dir))))))

(define max
  (lambda (curmax . rest)
    (if (null? rest)
        curmax
        (let ((next-num (car rest)))
          (apply max
                 (cons (if (> next-num curmax) next-num curmax)
                       (cdr rest)))))))

(define all
  (lambda (f l)
    (cond
      ((null? l) #t)
      ((not (f (car l))) (all f (cdr l)))
      (else #f))))

(define any
  (lambda (f l)
    (cond
      ((null? l) #f)
      ((f (car l)) #t)
      (else (any f (cdr l))))))

(define string->list
  (lambda (str)
    (let ((len (string-length str)))
      (letrec ((loop
                (lambda (i lst)
                  (if (= i len)
                      (reverse lst)
                      (loop (+ i 1)
                            (cons (string-ref str i)
                                  lst))))))
        (loop 0)))))

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

(define-macro cond-expand
  (lambda (body)
    (letrec
        ((loop
         (lambda (body)
           (if (null? body)
               #f
               (let ((elem (car body)))
                 (cond
                   ((eqv? (car elem) 'else)
                    (cons 'begin (cdr elem)))
                   ((and (pair? elem)
                          (passes? (car elem)))
                    (cons 'begin (cdr elem)))
                   (else (loop (cdr body))))))))
         (passes?
          (lambda (boolean-form)
            (cond
              ((eqv? boolean-form 'miniscm-unslisp) #t)
              ((eqv? boolean-form 'r3rs) #t)
              ((symbol? boolean-form) #f)
              ((not (pair? boolean-form)) (error "invalid boolean form"))
              ((eqv? (car boolean-form) 'and)
               (all passes? (cdr boolean-form)))
              ((eqv? (car boolean-form) 'or)
               (any passes? (cdr boolean-form)))
              ((eqv? (car boolean-form) 'not)
               (not (passes? (cadr boolean-form))))
              (else (error "invalid boolean function"))))))
      (loop (cdr body)))))

(define (abs x)
  (if (< x 0)
      (- x)
      x))