;;; -*-scheme-*-

;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Mes.
;;;
;;; GNU Mes 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.
;;;
;;; GNU Mes 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 GNU Mes.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;;; scm.mes is loaded after base, quasiquote and let.  It provides
;;; basic Scheme functions bringing Mes close to basic RRS Scheme (no
;;; labels, processes, fluids or throw/catch).

;;; Code:

(mes-use-module (mes let))

(define (cadddr x) (car (cdddr x)))

(define-macro (case val . args)
  (if (null? args) #f
      (let ((clause (car args)))
        (let ((pred (car clause)))
          (let ((body (cdr clause)))
           (if (pair? pred) `(if ,(if (null? (cdr pred))
                                      `(eq? ,val ',(car pred))
                                      `(member ,val ',pred))
                                 (begin ,@body)
                                 (case ,val ,@(cdr args)))
               `(begin ,@body)))))))

(define-macro (when expr . body)
  `(if ,expr
       ((lambda () ,@body))))

(define-macro (unless expr . body)
  `(if (not ,expr)
       ((lambda () ,@body))))

(define-macro (do init test . body)
  `(let loop ((,(caar init) ,(cadar init)))
     (when (not ,@test)
       ,@body
       (loop ,@(cddar init)))))

(define (for-each f l . xr)
  (if (and (pair? l)
           (or (null? xr)
               (pair? (car xr))))
      (if (null? xr) (begin (f (car l)) (for-each f (cdr l)))
          (if (null? (cdr xr)) (begin (f (car l) (caar xr)) (for-each f (cdr l) (cdar xr)))))))

(define core:error error)

(define (error who . rest)
  (display "error:" (current-error-port))
  (display who (current-error-port))
  (display ":" (current-error-port))
  (display rest (current-error-port))
  (newline (current-error-port))
  (display "exiting...\n" (current-error-port))
  (core:error (if (symbol? who) who 'error) (cons who rest)))

(define (syntax-error message . rest)
  (display "syntax-error:" (current-error-port))
  (display message (current-error-port))
  (display ":" (current-error-port))
  (display rest (current-error-port))
  (newline (current-error-port))
  (core:error 'syntax-error (cons message rest)))


(define integer? number?)

(define (read . port)
  (if (null? port) (read-env (current-module))
      (let* ((prev (set-current-input-port (car port)))
             (result (read-env (current-module))))
        result)))

(if (not (defined? 'peek-char))
    (define (peek-char)
      (integer->char (peek-byte))))

(if (not (defined? 'read-char))
    (define (read-char)
      (integer->char (read-byte))))

(if (not (defined? 'unread-char))
    (define (unread-char c)
      (integer->char (unread-byte (char->integer c)))))

(define (assq-set! alist key val)
  (let ((entry (assq key alist)))
    (if (not entry) (acons key val alist)
        (let ((entry (set-cdr! entry val)))
          alist))))

(define (assq-ref alist key)
  (and alist
       (let ((entry (assq key alist)))
         (if entry (cdr entry)
             #f))))

(define assv assq)
(define assv-ref assq-ref)

(define (assoc-ref alist key)
  (and (pair? alist)
       (let ((entry (assoc key alist)))
         (if entry (cdr entry)
             #f))))

(define (assoc-set! alist key value)
  (let ((entry (assoc key alist)))
    (if (not entry) (acons key value alist)
        (let ((entry (set-cdr! entry value)))
          alist))))

(define memv memq)

(define (member x lst)
  (if (null? lst) #f
      (if (equal? x (car lst)) lst
          (member x (cdr lst)))))


;;; Lists
(define (make-list n . x)
  (let ((fill (if (pair? x) (car x) *unspecified*)))
    (let loop ((n n))
      (if (= 0 n) '()
          (cons fill (loop (- n 1)))))))

(define (list-ref lst k)
  (let loop ((lst lst) (k k))
    (if (= 0 k) (car lst)
        (loop (cdr lst) (- k 1)))))

(define (list-set! lst k v)
  (let loop ((lst lst) (k k))
    (if (= 0 k) (set-car! lst v)
        (loop (cdr lst) (- k 1)))))

(define (list-head x n)
  (if (= 0 n) '()
      (cons (car x) (list-head (cdr x) (- n 1)))))

(define (list-tail x n)
  (if (= 0 n) x
      (list-tail (cdr x) (- n 1))))

(define (iota n)
  (if (<= n 0) '()
      (append2 (iota (- n 1)) (list (- n 1)))))

(define (reverse lst)
  (let loop ((lst lst) (r '()))
    (if (null? lst) r
        (loop (cdr lst) (cons (car lst) r)))))

(define (filter pred lst)
  (let loop ((lst lst))
    (if (null? lst) '()
        (if (pred (car lst))
            (cons (car lst) (loop (cdr lst)))
            (loop (cdr lst))))))

(define (delete x lst)
  (filter (lambda (e) (not (equal? e x))) lst))

(define (delq x lst)
  (filter (lambda (e) (not (eq? e x))) lst))

(define (compose proc . rest)
  (if (null? rest) proc
      (lambda args
        (proc (apply (apply compose rest) args)))))


;; Vector
(define (vector . rest) (list->vector rest))
(define (make-vector n . x)
  (if (null? x) (core:make-vector n)
      (list->vector (apply make-list (cons n x)))))

(define (vector-copy x)
  (list->vector (vector->list x)))


;;; Strings/srfi-13
(define (make-string n . fill)
  (list->string (apply make-list n fill)))

(define (string-set! s k v)
  (list->string (list-set! (string->list s) k v)))

(define (substring s start . rest)
  (let* ((end (and (pair? rest) (car rest)))
         (lst (list-tail (string->list s) start)))
    (list->string (if (not end) lst
                      (list-head lst (- end start))))))

(define (string-prefix? prefix string)
  (let ((length (string-length string))
        (prefix-length (string-length prefix)))
  (and
   (>= length prefix-length)
   (equal? (substring string 0 prefix-length) prefix))))

(define (string-suffix? suffix string)
  (let ((length (string-length string))
        (suffix-length (string-length suffix)))
    (and
     (>= length suffix-length)
     (equal? (substring string (- length suffix-length)) suffix))))

(define (string->number s . rest)
  (if (string-prefix? "#x" s) (string->number (string-drop s 2) 16)
      (let ((lst (string->list s)))
        (and (pair? lst)
             (let* ((radix (if (null? rest) 10 (car rest)))
                    (sign (if (and (pair? lst) (char=? (car lst) #\-)) -1 1))
                    (lst (if (= sign -1) (cdr lst) lst)))
               (let loop ((lst lst) (n 0))
                 (if (null? lst) (* sign n)
                     (let ((i (char->integer (car lst))))
                       (cond ((and (>= i (char->integer #\0))
                                   (<= i (char->integer #\9)))
                              (let ((d (char->integer #\0)))
                                (loop (cdr lst) (+ (* n radix) (- i d)))))
                             ((and (= radix 16)
                                   (>= i (char->integer #\a))
                                   (<= i (char->integer #\f)))
                              (let ((d (char->integer #\a)))
                                (loop (cdr lst) (+ (* n radix) (- i (- d 10))))))
                             ((and (= radix 16)
                                   (>= i (char->integer #\A))
                                   (<= i (char->integer #\F)))
                              (let ((d (char->integer #\A)))
                                (loop (cdr lst) (+ (* n radix) (- i (- d 10))))))
                             ((= i (char->integer #\.)) ; minimal FLOAT support
                              (let ((fraction (cdr lst)))
                                (if (null? fraction) n
                                    (let ((fraction ((compose string->number list->string) fraction)))
                                      (and fraction n))))) ; FLOAT as integer
                             (else #f))))))))))

(define inexact->exact identity)

(define (number->string n . rest)
  (let* ((radix (if (null? rest) 10 (car rest)))
         (sign (if (< n 0) '(#\-) '())))
    (let loop ((n (abs n)) (lst '()))
      (let* ((i (abs (remainder n radix)))
             (lst (cons (integer->char (+ i (if (< i 10) (char->integer #\0)
                                                (- (char->integer #\a) 10)))) lst))
             (n (quotient n radix)))
        (if (= 0 n) (list->string (append sign lst))
            (loop n lst))))))


;;; Symbols
(define (symbol-prefix? prefix symbol)
  (string-prefix? (symbol->string prefix) (symbol->string symbol)))

(define (symbol-append . rest)
  (string->symbol (apply string-append (map symbol->string rest))))

(define gensym
  (let ((counter 0))
    (lambda (. rest)
      (let ((value (number->string counter)))
        (set! counter (+ counter 1))
        (string->symbol (string-append "g" value))))))


;;; Keywords
(define (keyword->symbol s)
  (string->symbol (keyword->string s)))


;;; Characters
(define (char=? x y)
  (and (char? x) (char? y)
       (eq? x y)))

(define (char<? a b) (< (char->integer a) (char->integer b)))
(define (char>? a b) (> (char->integer a) (char->integer b)))
(define (char<=? a b) (<= (char->integer a) (char->integer b)))
(define (char>=? a b) (>= (char->integer a) (char->integer b)))

(define (char-alphabetic? x)
  (and (char? x)
       (let ((i (char->integer x)))
        (or (and (>= i (char->integer #\A)) (<= i (char->integer #\Z)))
            (and (>= i (char->integer #\a)) (<= i (char->integer #\z)))))))

(define (char-numeric? x)
  (and (char? x)
       (let ((i (char->integer x)))
         (and (>= i (char->integer #\0)) (<= i (char->integer #\9))))))


;;; Math
(define quotient /)

(define (<= . rest)
  (or (apply < rest)
      (apply = rest)))

(define (>= . rest)
  (or (apply > rest)
      (apply = rest)))

(define (remainder x y)
  (- x (* (quotient x y) y)))

(define (even? x)
  (= 0 (remainder x 2)))

(define (odd? x)
  (= 1 (remainder x 2)))

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

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

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

(define (1+ x)
  (+ x 1))

(define (1- x)
  (- x 1))

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

(define (expt x y)
  (let loop ((s 1) (count y))
    (if (= 0 count) s
        (loop (* s x) (- count 1)))))

(define (max x . rest)
  (if (null? rest) x
      (let ((y (car rest)))
        (let ((z (if (> x y) x y)))
          (apply max (cons z (cdr rest)))))))

(define (min x . rest)
  (if (null? rest) x
      (let ((y (car rest)))
        (let ((z (if (< x y) x y)))
          (apply min (cons z (cdr rest)))))))

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

(define ceil identity)
(define floor identity)
(define round identity)
(define inexact->exact identity)
(define exact->inexact identity)

(define (const . rest)
  (lambda (. _)
    (car rest)))
