2016-07-09 12:23:58 +01:00
|
|
|
|
;;; -*-scheme-*-
|
2016-05-15 23:07:44 +01:00
|
|
|
|
|
2018-07-22 13:24:36 +01:00
|
|
|
|
;;; GNU Mes --- Maxwell Equations of Software
|
2019-03-02 13:33:58 +00:00
|
|
|
|
;;; Copyright © 2016,2017,2018,2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
2016-05-15 23:07:44 +01:00
|
|
|
|
;;;
|
2018-07-22 13:24:36 +01:00
|
|
|
|
;;; This file is part of GNU Mes.
|
2016-05-15 23:07:44 +01:00
|
|
|
|
;;;
|
2018-07-22 13:24:36 +01:00
|
|
|
|
;;; GNU Mes is free software; you can redistribute it and/or modify it
|
2016-05-15 23:07:44 +01:00
|
|
|
|
;;; 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.
|
|
|
|
|
;;;
|
2018-07-22 13:24:36 +01:00
|
|
|
|
;;; GNU Mes is distributed in the hope that it will be useful, but
|
2016-05-15 23:07:44 +01:00
|
|
|
|
;;; 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
|
2018-07-22 13:24:36 +01:00
|
|
|
|
;;; along with GNU Mes. If not, see <http://www.gnu.org/licenses/>.
|
2016-05-15 23:07:44 +01:00
|
|
|
|
|
2016-10-12 22:40:11 +01:00
|
|
|
|
;;; 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:
|
|
|
|
|
|
2016-12-07 19:26:41 +00:00
|
|
|
|
(mes-use-module (mes let))
|
|
|
|
|
|
2016-08-14 00:44:42 +01:00
|
|
|
|
(define (cadddr x) (car (cdddr x)))
|
|
|
|
|
|
2016-07-25 00:12:22 +01:00
|
|
|
|
(define-macro (case val . args)
|
2016-10-21 09:52:59 +01:00
|
|
|
|
(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)))))))
|
2016-07-19 20:37:39 +01:00
|
|
|
|
|
2016-07-25 13:39:56 +01:00
|
|
|
|
(define-macro (when expr . body)
|
|
|
|
|
`(if ,expr
|
|
|
|
|
((lambda () ,@body))))
|
2016-07-19 20:37:39 +01:00
|
|
|
|
|
2016-12-20 14:48:10 +00:00
|
|
|
|
(define-macro (unless expr . body)
|
|
|
|
|
`(if (not ,expr)
|
|
|
|
|
((lambda () ,@body))))
|
|
|
|
|
|
2016-07-25 13:39:56 +01:00
|
|
|
|
(define-macro (do init test . body)
|
|
|
|
|
`(let loop ((,(caar init) ,(cadar init)))
|
|
|
|
|
(when (not ,@test)
|
|
|
|
|
,@body
|
|
|
|
|
(loop ,@(cddar init)))))
|
2016-07-19 20:37:39 +01:00
|
|
|
|
|
2019-03-02 13:33:58 +00:00
|
|
|
|
(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)))))))
|
2016-07-09 21:01:13 +01:00
|
|
|
|
|
2017-01-03 23:11:47 +00:00
|
|
|
|
(define core:error error)
|
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
(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))
|
2017-01-03 23:11:47 +00:00
|
|
|
|
(core:error (if (symbol? who) who 'error) (cons who rest)))
|
2016-08-13 16:05:29 +01:00
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
(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))
|
2017-01-03 23:11:47 +00:00
|
|
|
|
(newline (current-error-port))
|
|
|
|
|
(core:error 'syntax-error (cons message rest)))
|
2016-08-13 17:42:11 +01:00
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
|
|
|
|
|
(define integer? number?)
|
|
|
|
|
|
2019-05-15 23:05:47 +01:00
|
|
|
|
(define (read . port)
|
|
|
|
|
(if (null? port) (read-env (current-module))
|
|
|
|
|
(let* ((prev (set-current-input-port (car port)))
|
|
|
|
|
(result (read-env (current-module))))
|
|
|
|
|
result)))
|
|
|
|
|
|
mes: resurrect full reader in C core.
* module/mes/read-0.mes (defined?): New function.
(eat-whitespace, read-env, read-word, read-block-comment,
read-line-comment, read-list, read-character, read-hex, read-octal,
reader:read-string, lookup, read-hash, read-word): Only define if
not %c-reader.
* module/mes/base-0.mes (defined?): Remove.
* src/mes.c[MES_C_READER]: Set ARENA_SIZE=10000000.
(scm_symbol_quasiquote scm_symbol_unquote,
scm_symbol_unquote_splicing, scm_symbol_syntax,
scm_symbol_quasisyntax, scm_symbol_unsyntax,
scm_symbol_unsyntax_splicing): New symbol.
(scm_symbol_c_reader): New symbol.
(MAKE_KEYWORD)[MES_C_READER]: New define.
(mes_symbols): Define %c_reader.
* src/reader.c (read_word_)[MES_C_READER]: Extend to full Scheme
reader.
(eat_whitespace)[MES_C_READER]: Likewise.
(read_block_comment, read_hash, read_word, read_character,
read_octal, read_hex, append_char, read_string)[MES_C_READER]:
Likewise.
* make.scm (bin.gcc,bin.mescc): Define MES_C_READER=1.
2017-11-29 20:42:50 +00:00
|
|
|
|
(if (not (defined? 'peek-char))
|
|
|
|
|
(define (peek-char)
|
|
|
|
|
(integer->char (peek-byte))))
|
2016-12-23 15:26:00 +00:00
|
|
|
|
|
mes: resurrect full reader in C core.
* module/mes/read-0.mes (defined?): New function.
(eat-whitespace, read-env, read-word, read-block-comment,
read-line-comment, read-list, read-character, read-hex, read-octal,
reader:read-string, lookup, read-hash, read-word): Only define if
not %c-reader.
* module/mes/base-0.mes (defined?): Remove.
* src/mes.c[MES_C_READER]: Set ARENA_SIZE=10000000.
(scm_symbol_quasiquote scm_symbol_unquote,
scm_symbol_unquote_splicing, scm_symbol_syntax,
scm_symbol_quasisyntax, scm_symbol_unsyntax,
scm_symbol_unsyntax_splicing): New symbol.
(scm_symbol_c_reader): New symbol.
(MAKE_KEYWORD)[MES_C_READER]: New define.
(mes_symbols): Define %c_reader.
* src/reader.c (read_word_)[MES_C_READER]: Extend to full Scheme
reader.
(eat_whitespace)[MES_C_READER]: Likewise.
(read_block_comment, read_hash, read_word, read_character,
read_octal, read_hex, append_char, read_string)[MES_C_READER]:
Likewise.
* make.scm (bin.gcc,bin.mescc): Define MES_C_READER=1.
2017-11-29 20:42:50 +00:00
|
|
|
|
(if (not (defined? 'read-char))
|
|
|
|
|
(define (read-char)
|
|
|
|
|
(integer->char (read-byte))))
|
2016-12-23 15:26:00 +00:00
|
|
|
|
|
mes: resurrect full reader in C core.
* module/mes/read-0.mes (defined?): New function.
(eat-whitespace, read-env, read-word, read-block-comment,
read-line-comment, read-list, read-character, read-hex, read-octal,
reader:read-string, lookup, read-hash, read-word): Only define if
not %c-reader.
* module/mes/base-0.mes (defined?): Remove.
* src/mes.c[MES_C_READER]: Set ARENA_SIZE=10000000.
(scm_symbol_quasiquote scm_symbol_unquote,
scm_symbol_unquote_splicing, scm_symbol_syntax,
scm_symbol_quasisyntax, scm_symbol_unsyntax,
scm_symbol_unsyntax_splicing): New symbol.
(scm_symbol_c_reader): New symbol.
(MAKE_KEYWORD)[MES_C_READER]: New define.
(mes_symbols): Define %c_reader.
* src/reader.c (read_word_)[MES_C_READER]: Extend to full Scheme
reader.
(eat_whitespace)[MES_C_READER]: Likewise.
(read_block_comment, read_hash, read_word, read_character,
read_octal, read_hex, append_char, read_string)[MES_C_READER]:
Likewise.
* make.scm (bin.gcc,bin.mescc): Define MES_C_READER=1.
2017-11-29 20:42:50 +00:00
|
|
|
|
(if (not (defined? 'unread-char))
|
|
|
|
|
(define (unread-char c)
|
2018-01-04 20:36:46 +00:00
|
|
|
|
(integer->char (unread-byte (char->integer c)))))
|
2016-12-23 15:26:00 +00:00
|
|
|
|
|
2016-07-23 00:38:25 +01:00
|
|
|
|
(define (assq-set! alist key val)
|
|
|
|
|
(let ((entry (assq key alist)))
|
2017-04-01 06:23:10 +01:00
|
|
|
|
(if (not entry) (acons key val alist)
|
|
|
|
|
(let ((entry (set-cdr! entry val)))
|
|
|
|
|
alist))))
|
2016-07-23 00:38:25 +01:00
|
|
|
|
|
|
|
|
|
(define (assq-ref alist key)
|
2018-12-15 11:56:15 +00:00
|
|
|
|
(and alist
|
|
|
|
|
(let ((entry (assq key alist)))
|
|
|
|
|
(if entry (cdr entry)
|
|
|
|
|
#f))))
|
2016-07-23 00:38:25 +01:00
|
|
|
|
|
2016-07-19 20:37:39 +01:00
|
|
|
|
(define assv assq)
|
2016-07-24 23:06:18 +01:00
|
|
|
|
(define assv-ref assq-ref)
|
2016-07-23 00:38:25 +01:00
|
|
|
|
|
2016-07-25 00:12:22 +01:00
|
|
|
|
(define (assoc-ref alist key)
|
2018-12-15 11:56:15 +00:00
|
|
|
|
(and (pair? alist)
|
|
|
|
|
(let ((entry (assoc key alist)))
|
|
|
|
|
(if entry (cdr entry)
|
|
|
|
|
#f))))
|
2016-07-25 00:12:22 +01:00
|
|
|
|
|
2017-03-27 06:01:15 +01:00
|
|
|
|
(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))))
|
|
|
|
|
|
2016-07-19 20:37:39 +01:00
|
|
|
|
(define memv memq)
|
|
|
|
|
|
2018-04-07 12:15:26 +01:00
|
|
|
|
(define (member x lst)
|
|
|
|
|
(if (null? lst) #f
|
|
|
|
|
(if (equal? x (car lst)) lst
|
|
|
|
|
(member x (cdr lst)))))
|
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
|
|
|
|
|
;;; 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)))))
|
|
|
|
|
|
2016-12-25 23:16:37 +00:00
|
|
|
|
(define (list-set! lst k v)
|
|
|
|
|
(let loop ((lst lst) (k k))
|
|
|
|
|
(if (= 0 k) (set-car! lst v)
|
|
|
|
|
(loop (cdr lst) (- k 1)))))
|
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
(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)
|
2018-04-20 13:38:24 +01:00
|
|
|
|
(let loop ((lst lst) (r '()))
|
|
|
|
|
(if (null? lst) r
|
|
|
|
|
(loop (cdr lst) (cons (car lst) r)))))
|
2016-12-23 19:09:57 +00:00
|
|
|
|
|
|
|
|
|
(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))
|
|
|
|
|
|
2017-03-26 23:35:36 +01:00
|
|
|
|
(define (compose proc . rest)
|
|
|
|
|
(if (null? rest) proc
|
|
|
|
|
(lambda args
|
|
|
|
|
(proc (apply (apply compose rest) args)))))
|
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
|
|
|
|
|
;; Vector
|
|
|
|
|
(define (vector . rest) (list->vector rest))
|
|
|
|
|
|
|
|
|
|
(define (vector-copy x)
|
|
|
|
|
(list->vector (vector->list x)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;; Strings/srfi-13
|
2018-01-02 20:35:55 +00:00
|
|
|
|
(define (make-string n . fill)
|
|
|
|
|
(list->string (apply make-list n fill)))
|
|
|
|
|
|
2016-12-25 23:16:37 +00:00
|
|
|
|
(define (string-set! s k v)
|
|
|
|
|
(list->string (list-set! (string->list s) k v)))
|
|
|
|
|
|
2016-12-23 20:44:54 +00:00
|
|
|
|
(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))))))
|
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
(define (string-prefix? prefix string)
|
2017-05-18 23:23:13 +01:00
|
|
|
|
(let ((length (string-length string))
|
|
|
|
|
(prefix-length (string-length prefix)))
|
2016-12-23 19:09:57 +00:00
|
|
|
|
(and
|
2017-05-18 23:23:13 +01:00
|
|
|
|
(>= 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))))
|
2016-12-23 19:09:57 +00:00
|
|
|
|
|
2017-01-04 20:11:52 +00:00
|
|
|
|
(define (string->number s . rest)
|
2019-08-02 21:52:46 +01:00
|
|
|
|
(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))))))))))
|
2018-05-18 14:28:05 +01:00
|
|
|
|
|
|
|
|
|
(define inexact->exact identity)
|
2017-01-04 20:11:52 +00:00
|
|
|
|
|
|
|
|
|
(define (number->string n . rest)
|
|
|
|
|
(let* ((radix (if (null? rest) 10 (car rest)))
|
|
|
|
|
(sign (if (< n 0) '(#\-) '())))
|
2016-12-23 21:08:03 +00:00
|
|
|
|
(let loop ((n (abs n)) (lst '()))
|
2019-07-05 14:52:04 +01:00
|
|
|
|
(let* ((i (abs (remainder n radix)))
|
2017-05-23 05:28:37 +01:00
|
|
|
|
(lst (cons (integer->char (+ i (if (< i 10) (char->integer #\0)
|
2017-01-04 20:11:52 +00:00
|
|
|
|
(- (char->integer #\a) 10)))) lst))
|
|
|
|
|
(n (quotient n radix)))
|
2016-12-23 21:08:03 +00:00
|
|
|
|
(if (= 0 n) (list->string (append sign lst))
|
|
|
|
|
(loop n lst))))))
|
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
|
|
|
|
|
;;; 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))))))
|
|
|
|
|
|
2016-12-23 22:25:49 +00:00
|
|
|
|
|
|
|
|
|
;;; Keywords
|
|
|
|
|
(define (keyword->symbol s)
|
2018-11-11 15:25:36 +00:00
|
|
|
|
(string->symbol (keyword->string s)))
|
2016-12-23 22:25:49 +00:00
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
|
|
|
|
|
;;; Characters
|
|
|
|
|
(define (char=? x y)
|
|
|
|
|
(and (char? x) (char? y)
|
|
|
|
|
(eq? x y)))
|
2016-07-17 11:56:31 +01:00
|
|
|
|
|
2016-12-23 19:09:57 +00:00
|
|
|
|
(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
|
2017-04-02 10:34:40 +01:00
|
|
|
|
(define quotient /)
|
|
|
|
|
|
2016-07-24 15:29:38 +01:00
|
|
|
|
(define (<= . rest)
|
|
|
|
|
(or (apply < rest)
|
|
|
|
|
(apply = rest)))
|
2016-07-17 11:56:31 +01:00
|
|
|
|
|
2016-07-24 15:29:38 +01:00
|
|
|
|
(define (>= . rest)
|
|
|
|
|
(or (apply > rest)
|
|
|
|
|
(apply = rest)))
|
2016-07-17 11:56:31 +01:00
|
|
|
|
|
2016-07-24 16:11:49 +01:00
|
|
|
|
(define (remainder x y)
|
2016-10-12 22:40:11 +01:00
|
|
|
|
(- x (* (quotient x y) y)))
|
2016-07-24 16:11:49 +01:00
|
|
|
|
|
2016-12-20 09:41:39 +00:00
|
|
|
|
(define (even? x)
|
|
|
|
|
(= 0 (remainder x 2)))
|
|
|
|
|
|
|
|
|
|
(define (odd? x)
|
|
|
|
|
(= 1 (remainder x 2)))
|
|
|
|
|
|
2016-12-20 09:57:09 +00:00
|
|
|
|
(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))
|
|
|
|
|
|
2016-12-20 20:22:21 +00:00
|
|
|
|
(define (abs x)
|
|
|
|
|
(if (>= x 0) x (- x)))
|
|
|
|
|
|
2016-07-24 16:16:55 +01:00
|
|
|
|
(define (expt x y)
|
|
|
|
|
(let loop ((s 1) (count y))
|
|
|
|
|
(if (= 0 count) s
|
|
|
|
|
(loop (* s x) (- count 1)))))
|
|
|
|
|
|
2016-07-24 15:34:54 +01:00
|
|
|
|
(define (max x . rest)
|
|
|
|
|
(if (null? rest) x
|
2016-10-21 09:52:59 +01:00
|
|
|
|
(let ((y (car rest)))
|
|
|
|
|
(let ((z (if (> x y) x y)))
|
|
|
|
|
(apply max (cons z (cdr rest)))))))
|
2016-07-24 15:34:54 +01:00
|
|
|
|
|
|
|
|
|
(define (min x . rest)
|
|
|
|
|
(if (null? rest) x
|
2016-10-21 09:52:59 +01:00
|
|
|
|
(let ((y (car rest)))
|
|
|
|
|
(let ((z (if (< x y) x y)))
|
|
|
|
|
(apply min (cons z (cdr rest)))))))
|
2017-05-21 11:33:16 +01:00
|
|
|
|
|
|
|
|
|
(define (negate proc)
|
|
|
|
|
(lambda args
|
|
|
|
|
(not (apply proc args))))
|
2018-05-20 12:18:36 +01:00
|
|
|
|
|
2018-10-21 11:07:06 +01:00
|
|
|
|
(define ceil identity)
|
|
|
|
|
(define floor identity)
|
|
|
|
|
(define round identity)
|
|
|
|
|
(define inexact->exact identity)
|
|
|
|
|
(define exact->inexact identity)
|
|
|
|
|
|
2018-05-20 12:18:36 +01:00
|
|
|
|
(define (const . rest)
|
|
|
|
|
(lambda (. _)
|
|
|
|
|
(car rest)))
|