1689 lines
72 KiB
Racket
1689 lines
72 KiB
Racket
#lang whalesong/base
|
|
|
|
;; A module language that provides bindings for the Simply Scheme
|
|
;; language.
|
|
|
|
;; Much of this code was automatically generated by utilities
|
|
;; I (dyoo) wrote in private/, but I'm hand-massaging some of
|
|
;; the definitions here to support things like trace.
|
|
|
|
|
|
|
|
(define simply-scheme:* *)
|
|
(define simply-scheme:+ +)
|
|
(define simply-scheme:- -)
|
|
(define simply-scheme:/ /)
|
|
(define simply-scheme:< <)
|
|
(define simply-scheme:<= <=)
|
|
(define simply-scheme:= =)
|
|
(define simply-scheme:> >)
|
|
(define simply-scheme:>= >=)
|
|
(define simply-scheme:abs abs)
|
|
(define simply-scheme:acos acos)
|
|
(define simply-scheme:asin asin)
|
|
(define simply-scheme:atan atan)
|
|
(define simply-scheme:ceiling ceiling)
|
|
;(define simply-scheme:close-input-port close-input-port)
|
|
;(define simply-scheme:close-output-port close-output-port)
|
|
(define simply-scheme:cos cos)
|
|
(define simply-scheme:equal? equal?)
|
|
(define simply-scheme:even? even?)
|
|
(define simply-scheme:exp exp)
|
|
(define simply-scheme:expt expt)
|
|
(define simply-scheme:floor floor)
|
|
(define simply-scheme:gcd gcd)
|
|
(define simply-scheme:integer? integer?)
|
|
(define simply-scheme:lcm lcm)
|
|
(define simply-scheme:list-ref list-ref)
|
|
(define simply-scheme:log log)
|
|
(define simply-scheme:make-vector make-vector)
|
|
(define simply-scheme:max max)
|
|
(define simply-scheme:min min)
|
|
(define simply-scheme:modulo modulo)
|
|
(define simply-scheme:negative? negative?)
|
|
(define simply-scheme:number->string number->string)
|
|
(define simply-scheme:number? number?)
|
|
(define simply-scheme:odd? odd?)
|
|
#;(define simply-scheme:open-input-file open-input-file)
|
|
#;(define simply-scheme:open-output-file open-output-file)
|
|
(define simply-scheme:positive? positive?)
|
|
(define simply-scheme:quotient quotient)
|
|
(define simply-scheme:random random)
|
|
#;(define simply-scheme:read-line read-line)
|
|
#;(define simply-scheme:read-string read-string)
|
|
(define simply-scheme:remainder remainder)
|
|
(define simply-scheme:round round)
|
|
(define simply-scheme:sin sin)
|
|
(define simply-scheme:sqrt sqrt)
|
|
(define simply-scheme:tan tan)
|
|
(define simply-scheme:truncate truncate)
|
|
(define simply-scheme:vector-ref vector-ref)
|
|
(define simply-scheme:vector-set! vector-set!)
|
|
(define simply-scheme:zero? zero?)
|
|
|
|
|
|
(void (if (simply-scheme:equal? 'foo (symbol->string 'foo))
|
|
(error "Simply.scm already loaded!!")
|
|
#f))
|
|
|
|
(void (if (char=? #\+ (string-ref (simply-scheme:number->string 1.0) 0))
|
|
(let-values (((old-ns) simply-scheme:number->string)
|
|
((char=?) char=?)
|
|
((string-ref) string-ref)
|
|
((substring) substring)
|
|
((string-length) string-length))
|
|
(set! simply-scheme:number->string
|
|
(lambda args
|
|
(let-values (((result) (apply old-ns args)))
|
|
(if (char=? #\+ (string-ref result 0))
|
|
(substring result 1 (string-length result))
|
|
result)))))
|
|
'no-problem))
|
|
|
|
(set! simply-scheme:number->string
|
|
(let-values (((old-ns) simply-scheme:number->string) ((string?) string?))
|
|
(lambda args (if (string? (car args)) (car args) (apply old-ns args)))))
|
|
|
|
(define-values
|
|
(whoops)
|
|
(let-values (((string?) string?)
|
|
((string-append) string-append)
|
|
((error) error)
|
|
((cons) cons)
|
|
((map) map)
|
|
((apply) apply))
|
|
(letrec-values (((error-printform)
|
|
(lambda (x)
|
|
(if (string? x) (string-append "\"" x "\"") x))))
|
|
(lambda (string . args)
|
|
(apply error (cons string (map error-printform args)))))))
|
|
|
|
(void
|
|
(if (if (inexact? (simply-scheme:round (simply-scheme:sqrt 2))) (exact? 1) #f)
|
|
(let-values (((old-round) simply-scheme:round)
|
|
((inexact->exact) inexact->exact))
|
|
(set! simply-scheme:round
|
|
(lambda (number) (inexact->exact (old-round number)))))
|
|
'no-problem))
|
|
|
|
(void (if (inexact? (simply-scheme:* 0.25 4))
|
|
(let-values (((rem) simply-scheme:remainder)
|
|
((quo) simply-scheme:quotient)
|
|
((inexact->exact) inexact->exact)
|
|
((integer?) simply-scheme:integer?))
|
|
(set! simply-scheme:remainder
|
|
(lambda (x y)
|
|
(rem
|
|
(if (integer? x) (inexact->exact x) x)
|
|
(if (integer? y) (inexact->exact y) y))))
|
|
(set! simply-scheme:quotient
|
|
(lambda (x y)
|
|
(quo
|
|
(if (integer? x) (inexact->exact x) x)
|
|
(if (integer? y) (inexact->exact y) y)))))
|
|
'done))
|
|
|
|
|
|
(set! simply-scheme:random
|
|
(let-values (((*seed*) 1)
|
|
((quotient) simply-scheme:quotient)
|
|
((modulo) simply-scheme:modulo)
|
|
((+) simply-scheme:+)
|
|
((-) simply-scheme:-)
|
|
((*) simply-scheme:*)
|
|
((>) simply-scheme:>))
|
|
(lambda (x)
|
|
(let-values (((hi) (quotient *seed* 127773)))
|
|
(let-values (((low) (modulo *seed* 127773)))
|
|
(let-values (((test) (- (* 16807 low) (* 2836 hi))))
|
|
(if (> test 0)
|
|
(set! *seed* test)
|
|
(set! *seed* (#%app + test (#%datum . 2147483647)))))))
|
|
(modulo *seed* x))))
|
|
|
|
(define-values
|
|
(word?)
|
|
(let-values (((number?) simply-scheme:number?)
|
|
((symbol?) symbol?)
|
|
((string?) string?))
|
|
(lambda (x)
|
|
(let-values (((or-part) (symbol? x)))
|
|
(if or-part
|
|
or-part
|
|
(let-values (((or-part) (number? x)))
|
|
(if or-part or-part (string? x))))))))
|
|
|
|
(define-values
|
|
(sentence?)
|
|
(let-values (((null?) null?)
|
|
((pair?) pair?)
|
|
((word?) word?)
|
|
((car) car)
|
|
((cdr) cdr))
|
|
(letrec-values (((list-of-words?)
|
|
(lambda (l)
|
|
(if (null? l)
|
|
(begin #t)
|
|
(if (pair? l)
|
|
(begin
|
|
(if (word? (car l)) (list-of-words? (cdr l)) #f))
|
|
(begin #f))))))
|
|
list-of-words?)))
|
|
|
|
(define-values
|
|
(empty?)
|
|
(let-values (((null?) null?) ((string?) string?) ((string=?) string=?))
|
|
(lambda (x)
|
|
(let-values (((or-part) (null? x)))
|
|
(if or-part or-part (if (string? x) (string=? x "") #f))))))
|
|
|
|
(define-values
|
|
(char-rank)
|
|
(let-values (((*the-char-ranks*) (simply-scheme:make-vector 256 3))
|
|
((=) simply-scheme:=)
|
|
((+) simply-scheme:+)
|
|
((string-ref) string-ref)
|
|
((string-length) string-length)
|
|
((vector-set!) simply-scheme:vector-set!)
|
|
((char->integer) char->integer)
|
|
((symbol->string) symbol->string)
|
|
((vector-ref) simply-scheme:vector-ref))
|
|
(letrec-values (((rank-string)
|
|
(lambda (str rank)
|
|
(letrec-values (((helper)
|
|
(lambda (i len)
|
|
(if (= i len)
|
|
'done
|
|
(begin
|
|
(vector-set!
|
|
*the-char-ranks*
|
|
(char->integer
|
|
(string-ref str i))
|
|
rank)
|
|
(helper (+ i 1) len))))))
|
|
(helper 0 (string-length str))))))
|
|
(rank-string (symbol->string 'abcdefghijklmnopqrstuvwxyz) 0)
|
|
(rank-string "!$%&*/:<=>?~_^" 0)
|
|
(rank-string "+-." 1)
|
|
(rank-string "0123456789" 2)
|
|
(lambda (char) (vector-ref *the-char-ranks* (char->integer char))))))
|
|
|
|
(define-values
|
|
(string->word)
|
|
(let-values (((=) simply-scheme:=)
|
|
((<=) simply-scheme:<=)
|
|
((+) simply-scheme:+)
|
|
((-) simply-scheme:-)
|
|
((char-rank) char-rank)
|
|
((string-ref) string-ref)
|
|
((string-length) string-length)
|
|
((string=?) string=?)
|
|
((not) not)
|
|
((char=?) char=?)
|
|
((string->number) string->number)
|
|
((string->symbol) string->symbol))
|
|
(lambda (string)
|
|
(letrec-values (((subsequents?)
|
|
(lambda (string i length)
|
|
(if (= i length)
|
|
(begin #t)
|
|
(if (<= (char-rank (string-ref string i)) 2)
|
|
(begin (subsequents? string (+ i 1) length))
|
|
(begin #f)))))
|
|
((special-id?)
|
|
(lambda (string)
|
|
(let-values (((or-part) (string=? string "+")))
|
|
(if or-part
|
|
or-part
|
|
(let-values (((or-part) (string=? string "-")))
|
|
(if or-part
|
|
or-part
|
|
(string=? string "...")))))))
|
|
((ok-symbol?)
|
|
(lambda (string)
|
|
(if (string=? string "")
|
|
#f
|
|
(let-values (((rank1)
|
|
(char-rank (string-ref string 0))))
|
|
(if (= rank1 0)
|
|
(begin
|
|
(subsequents?
|
|
string
|
|
1
|
|
(string-length string)))
|
|
(if (= rank1 1)
|
|
(begin (special-id? string))
|
|
(begin #f)))))))
|
|
((nn-helper)
|
|
(lambda (string i len seen-point?)
|
|
(if (= i len)
|
|
(begin
|
|
(if seen-point?
|
|
(not (char=? (string-ref string (- len 1)) #\0))
|
|
#t))
|
|
(if (char=? #\. (string-ref string i))
|
|
(begin
|
|
(if seen-point?
|
|
(begin #f)
|
|
(if (= (+ i 2) len)
|
|
(begin #t)
|
|
(begin (nn-helper string (+ i 1) len #t)))))
|
|
(if (= 2 (char-rank (string-ref string i)))
|
|
(begin
|
|
(nn-helper string (+ i 1) len seen-point?))
|
|
(begin #f))))))
|
|
((narrow-number?)
|
|
(lambda (string)
|
|
(if (string=? string "")
|
|
#f
|
|
(let-values (((c0) (string-ref string 0)))
|
|
(let-values (((start) 0))
|
|
(let-values (((len) (string-length string)))
|
|
(let-values (((cn)
|
|
(string-ref string (- len 1))))
|
|
(if (if (char=? c0 #\-) (not (= len 1)) #f)
|
|
(begin
|
|
(set! start (#%datum . 1))
|
|
(set! c0
|
|
(#%app
|
|
string-ref
|
|
string
|
|
(#%datum . 1))))
|
|
#f)
|
|
(if (not (= (char-rank cn) 2))
|
|
(begin #f)
|
|
(if (char=? c0 #\.)
|
|
(begin #f)
|
|
(if (char=? c0 #\0)
|
|
(begin
|
|
(if (= len 1)
|
|
(begin #t)
|
|
(if (= len 2)
|
|
(begin #f)
|
|
(if (char=?
|
|
(string-ref
|
|
string
|
|
(+ start 1))
|
|
#\.)
|
|
(begin
|
|
(nn-helper
|
|
string
|
|
(+ start 2)
|
|
len
|
|
#t))
|
|
(begin #f)))))
|
|
(begin
|
|
(nn-helper
|
|
string
|
|
start
|
|
len
|
|
#f)))))))))))))
|
|
(if (narrow-number? string)
|
|
(begin (string->number string))
|
|
(if (ok-symbol? string)
|
|
(begin (string->symbol string))
|
|
(begin string)))))))
|
|
|
|
(define-values
|
|
(char->word)
|
|
(let-values (((=) simply-scheme:=)
|
|
((char-rank) char-rank)
|
|
((make-string) make-string)
|
|
((string->symbol) string->symbol)
|
|
((string->number) string->number)
|
|
((char=?) char=?))
|
|
(lambda (char)
|
|
(let-values (((rank) (char-rank char)) ((string) (make-string 1 char)))
|
|
(if (= rank 0)
|
|
(begin (string->symbol string))
|
|
(if (= rank 2)
|
|
(begin (string->number string))
|
|
(if (char=? char #\+)
|
|
(begin '+)
|
|
(if (char=? char #\-) (begin '-) (begin string)))))))))
|
|
|
|
(define-values
|
|
(word->string)
|
|
(let-values (((number?) simply-scheme:number?)
|
|
((string?) string?)
|
|
((number->string) simply-scheme:number->string)
|
|
((symbol->string) symbol->string))
|
|
(lambda (wd)
|
|
(if (string? wd)
|
|
(begin wd)
|
|
(if (number? wd)
|
|
(begin (number->string wd))
|
|
(begin (symbol->string wd)))))))
|
|
|
|
(define-values
|
|
(count)
|
|
(let-values (((word?) word?)
|
|
((string-length) string-length)
|
|
((word->string) word->string)
|
|
((length) length))
|
|
(lambda (stuff)
|
|
(if (word? stuff) (string-length (word->string stuff)) (length stuff)))))
|
|
|
|
(define-values
|
|
(word)
|
|
(let-values (((string->word) string->word)
|
|
((apply) apply)
|
|
((string-append) string-append)
|
|
((map) map)
|
|
((word?) word?)
|
|
((word->string) word->string)
|
|
((whoops) whoops))
|
|
(lambda x
|
|
(string->word
|
|
(apply
|
|
string-append
|
|
(map
|
|
(lambda (arg)
|
|
(if (word? arg)
|
|
(word->string arg)
|
|
(whoops "Invalid argument to WORD: " arg)))
|
|
x))))))
|
|
|
|
(define-values
|
|
(se)
|
|
(let-values (((pair?) pair?)
|
|
((null?) null?)
|
|
((word?) word?)
|
|
((car) car)
|
|
((cons) cons)
|
|
((cdr) cdr)
|
|
((whoops) whoops))
|
|
(letrec-values (((paranoid-append)
|
|
(lambda (a original-a b)
|
|
(if (null? a)
|
|
(begin b)
|
|
(if (word? (car a))
|
|
(begin
|
|
(cons
|
|
(car a)
|
|
(paranoid-append (cdr a) original-a b)))
|
|
(begin
|
|
(whoops
|
|
"Argument to SENTENCE not a word or sentence"
|
|
original-a))))))
|
|
((combine-two)
|
|
(lambda (a b)
|
|
(if (pair? a)
|
|
(begin (paranoid-append a a b))
|
|
(if (null? a)
|
|
(begin b)
|
|
(if (word? a)
|
|
(begin (cons a b))
|
|
(begin
|
|
(whoops
|
|
"Argument to SENTENCE not a word or sentence:"
|
|
a)))))))
|
|
((real-se)
|
|
(lambda (args)
|
|
(if (null? args)
|
|
'()
|
|
(combine-two (car args) (real-se (cdr args)))))))
|
|
(lambda args (real-se args)))))
|
|
|
|
(define-values (sentence) se)
|
|
|
|
(define-values
|
|
(first)
|
|
(let-values (((pair?) pair?)
|
|
((char->word) char->word)
|
|
((string-ref) string-ref)
|
|
((word->string) word->string)
|
|
((car) car)
|
|
((empty?) empty?)
|
|
((whoops) whoops)
|
|
((word?) word?))
|
|
(letrec-values (((word-first)
|
|
(lambda (wd)
|
|
(char->word (string-ref (word->string wd) 0)))))
|
|
(lambda (x)
|
|
(if (pair? x)
|
|
(begin (car x))
|
|
(if (empty? x)
|
|
(begin (whoops "Invalid argument to FIRST: " x))
|
|
(if (word? x)
|
|
(begin (word-first x))
|
|
(begin (whoops "Invalid argument to FIRST: " x)))))))))
|
|
|
|
(define-values
|
|
(last)
|
|
(let-values (((pair?) pair?)
|
|
((-) simply-scheme:-)
|
|
((word->string) word->string)
|
|
((char->word) char->word)
|
|
((string-ref) string-ref)
|
|
((string-length) string-length)
|
|
((empty?) empty?)
|
|
((cdr) cdr)
|
|
((car) car)
|
|
((whoops) whoops)
|
|
((word?) word?))
|
|
(letrec-values (((word-last)
|
|
(lambda (wd)
|
|
(let-values (((s) (word->string wd)))
|
|
(char->word (string-ref s (- (string-length s) 1))))))
|
|
((list-last)
|
|
(lambda (lst)
|
|
(if (empty? (cdr lst))
|
|
(car lst)
|
|
(list-last (cdr lst))))))
|
|
(lambda (x)
|
|
(if (pair? x)
|
|
(begin (list-last x))
|
|
(if (empty? x)
|
|
(begin (whoops "Invalid argument to LAST: " x))
|
|
(if (word? x)
|
|
(begin (word-last x))
|
|
(begin (whoops "Invalid argument to LAST: " x)))))))))
|
|
|
|
(define-values
|
|
(bf)
|
|
(let-values (((pair?) pair?)
|
|
((substring) substring)
|
|
((string-length) string-length)
|
|
((string->word) string->word)
|
|
((word->string) word->string)
|
|
((cdr) cdr)
|
|
((empty?) empty?)
|
|
((whoops) whoops)
|
|
((word?) word?))
|
|
(letrec-values (((string-bf)
|
|
(lambda (s) (substring s 1 (string-length s))))
|
|
((word-bf)
|
|
(lambda (wd)
|
|
(string->word (string-bf (word->string wd))))))
|
|
(lambda (x)
|
|
(if (pair? x)
|
|
(begin (cdr x))
|
|
(if (empty? x)
|
|
(begin (whoops "Invalid argument to BUTFIRST: " x))
|
|
(if (word? x)
|
|
(begin (word-bf x))
|
|
(begin (whoops "Invalid argument to BUTFIRST: " x)))))))))
|
|
|
|
(define-values (butfirst) bf)
|
|
|
|
(define-values
|
|
(bl)
|
|
(let-values (((pair?) pair?)
|
|
((-) simply-scheme:-)
|
|
((cdr) cdr)
|
|
((cons) cons)
|
|
((car) car)
|
|
((substring) substring)
|
|
((string-length) string-length)
|
|
((string->word) string->word)
|
|
((word->string) word->string)
|
|
((empty?) empty?)
|
|
((whoops) whoops)
|
|
((word?) word?))
|
|
(letrec-values (((list-bl)
|
|
(lambda (list)
|
|
(if (null? (cdr list))
|
|
'()
|
|
(cons (car list) (list-bl (cdr list))))))
|
|
((string-bl)
|
|
(lambda (s) (substring s 0 (- (string-length s) 1))))
|
|
((word-bl)
|
|
(lambda (wd)
|
|
(string->word (string-bl (word->string wd))))))
|
|
(lambda (x)
|
|
(if (pair? x)
|
|
(begin (list-bl x))
|
|
(if (empty? x)
|
|
(begin (whoops "Invalid argument to BUTLAST: " x))
|
|
(if (word? x)
|
|
(begin (word-bl x))
|
|
(begin (whoops "Invalid argument to BUTLAST: " x)))))))))
|
|
|
|
(define-values (butlast) bl)
|
|
|
|
(define-values
|
|
(item)
|
|
(let-values (((>) simply-scheme:>)
|
|
((-) simply-scheme:-)
|
|
((<) simply-scheme:<)
|
|
((integer?) simply-scheme:integer?)
|
|
((list-ref) simply-scheme:list-ref)
|
|
((char->word) char->word)
|
|
((string-ref) string-ref)
|
|
((word->string) word->string)
|
|
((not) not)
|
|
((whoops) whoops)
|
|
((count) count)
|
|
((word?) word?)
|
|
((list?) list?))
|
|
(letrec-values (((word-item)
|
|
(lambda (n wd)
|
|
(char->word (string-ref (word->string wd) (- n 1))))))
|
|
(lambda (n stuff)
|
|
(if (not (integer? n))
|
|
(begin
|
|
(whoops "Invalid first argument to ITEM (must be an integer): " n))
|
|
(if (< n 1)
|
|
(begin
|
|
(whoops "Invalid first argument to ITEM (must be positive): " n))
|
|
(if (> n (count stuff))
|
|
(begin (whoops "No such item: " n stuff))
|
|
(if (word? stuff)
|
|
(begin (word-item n stuff))
|
|
(if (list? stuff)
|
|
(begin (list-ref stuff (- n 1)))
|
|
(begin
|
|
(whoops
|
|
"Invalid second argument to ITEM: "
|
|
stuff)))))))))))
|
|
|
|
(set! simply-scheme:equal?
|
|
(let-values (((vector-length) vector-length)
|
|
((=) simply-scheme:=)
|
|
((vector-ref) simply-scheme:vector-ref)
|
|
((+) simply-scheme:+)
|
|
((string?) string?)
|
|
((symbol?) symbol?)
|
|
((null?) null?)
|
|
((pair?) pair?)
|
|
((car) car)
|
|
((cdr) cdr)
|
|
((eq?) eq?)
|
|
((string=?) string=?)
|
|
((symbol->string) symbol->string)
|
|
((number?) simply-scheme:number?)
|
|
((string->word) string->word)
|
|
((vector?) vector?)
|
|
((eqv?) eqv?))
|
|
(letrec-values (((vector-equal?)
|
|
(lambda (v1 v2)
|
|
(let-values (((len1) (vector-length v1))
|
|
((len2) (vector-length v2)))
|
|
(letrec-values (((helper)
|
|
(lambda (i)
|
|
(if (= i len1)
|
|
#t
|
|
(if (simply-scheme:equal?
|
|
(vector-ref v1 i)
|
|
(vector-ref v2 i))
|
|
(helper (+ i 1))
|
|
#f)))))
|
|
(if (= len1 len2) (helper 0) #f))))))
|
|
(lambda (x y)
|
|
(if (null? x)
|
|
(begin (null? y))
|
|
(if (null? y)
|
|
(begin #f)
|
|
(if (pair? x)
|
|
(begin
|
|
(if (pair? y)
|
|
(if (simply-scheme:equal? (car x) (car y))
|
|
(simply-scheme:equal? (cdr x) (cdr y))
|
|
#f)
|
|
#f))
|
|
(if (pair? y)
|
|
(begin #f)
|
|
(if (symbol? x)
|
|
(begin
|
|
(let-values (((or-part) (if (symbol? y) (eq? x y) #f)))
|
|
(if or-part
|
|
or-part
|
|
(if (string? y) (string=? (symbol->string x) y) #f))))
|
|
(if (symbol? y)
|
|
(begin (if (string? x) (string=? x (symbol->string y)) #f))
|
|
(if (number? x)
|
|
(begin
|
|
(let-values (((or-part) (if (number? y) (= x y) #f)))
|
|
(if or-part
|
|
or-part
|
|
(if (string? y)
|
|
(let-values (((possible-num) (string->word y)))
|
|
(if (number? possible-num)
|
|
(= x possible-num)
|
|
#f))
|
|
#f))))
|
|
(if (number? y)
|
|
(begin
|
|
(if (string? x)
|
|
(let-values (((possible-num) (string->word x)))
|
|
(if (number? possible-num)
|
|
(= possible-num y)
|
|
#f))
|
|
#f))
|
|
(if (string? x)
|
|
(begin (if (string? y) (string=? x y) #f))
|
|
(if (string? y)
|
|
(begin #f)
|
|
(if (vector? x)
|
|
(begin (if (vector? y) (vector-equal? x y) #f))
|
|
(if (vector? y)
|
|
(begin #f)
|
|
(begin (eqv? x y))))))))))))))))))
|
|
|
|
(define-values
|
|
(member?)
|
|
(let-values (((>) simply-scheme:>)
|
|
((-) simply-scheme:-)
|
|
((<) simply-scheme:<)
|
|
((null?) null?)
|
|
((symbol?) symbol?)
|
|
((eq?) eq?)
|
|
((car) car)
|
|
((not) not)
|
|
((symbol->string) symbol->string)
|
|
((string=?) string=?)
|
|
((cdr) cdr)
|
|
((equal?) simply-scheme:equal?)
|
|
((word->string) word->string)
|
|
((string-length) string-length)
|
|
((whoops) whoops)
|
|
((string-ref) string-ref)
|
|
((char=?) char=?)
|
|
((list?) list?)
|
|
((number?) simply-scheme:number?)
|
|
((empty?) empty?)
|
|
((word?) word?)
|
|
((string?) string?))
|
|
(letrec-values (((symbol-in-list?)
|
|
(lambda (symbol string lst)
|
|
(if (null? lst)
|
|
(begin #f)
|
|
(let-values (((g174)
|
|
(if (symbol? (car lst))
|
|
(eq? symbol (car lst))
|
|
#f)))
|
|
(if g174
|
|
g174
|
|
(if (string? (car lst))
|
|
(begin
|
|
(if (not string)
|
|
(begin
|
|
(symbol-in-list?
|
|
symbol
|
|
(symbol->string symbol)
|
|
lst))
|
|
(if (string=? string (car lst))
|
|
(begin #t)
|
|
(begin
|
|
(symbol-in-list?
|
|
symbol
|
|
string
|
|
(cdr lst))))))
|
|
(begin
|
|
(symbol-in-list?
|
|
symbol
|
|
string
|
|
(cdr lst)))))))))
|
|
((word-in-list?)
|
|
(lambda (wd lst)
|
|
(if (null? lst)
|
|
(begin #f)
|
|
(if (equal? wd (car lst))
|
|
(begin #t)
|
|
(begin (word-in-list? wd (cdr lst)))))))
|
|
((word-in-word?)
|
|
(lambda (small big)
|
|
(let-values (((one-letter-str) (word->string small)))
|
|
(if (> (string-length one-letter-str) 1)
|
|
(whoops "Invalid arguments to MEMBER?: " small big)
|
|
(let-values (((big-str) (word->string big)))
|
|
(char-in-string?
|
|
(string-ref one-letter-str 0)
|
|
big-str
|
|
(- (string-length big-str) 1)))))))
|
|
((char-in-string?)
|
|
(lambda (char string i)
|
|
(if (< i 0)
|
|
(begin #f)
|
|
(if (char=? char (string-ref string i))
|
|
(begin #t)
|
|
(begin (char-in-string? char string (- i 1))))))))
|
|
(lambda (x stuff)
|
|
(if (empty? stuff)
|
|
(begin #f)
|
|
(if (word? stuff)
|
|
(begin (word-in-word? x stuff))
|
|
(if (not (list? stuff))
|
|
(begin (whoops "Invalid second argument to MEMBER?: " stuff))
|
|
(if (symbol? x)
|
|
(begin (symbol-in-list? x #f stuff))
|
|
(if (let-values (((or-part) (number? x)))
|
|
(if or-part or-part (string? x)))
|
|
(begin (word-in-list? x stuff))
|
|
(begin
|
|
(whoops "Invalid first argument to MEMBER?: " x)))))))))))
|
|
|
|
(define-values
|
|
(before?)
|
|
(let-values (((not) not)
|
|
((word?) word?)
|
|
((whoops) whoops)
|
|
((string<?) string<?)
|
|
((word->string) word->string))
|
|
(lambda (wd1 wd2)
|
|
(if (not (word? wd1))
|
|
(begin (whoops "Invalid first argument to BEFORE? (not a word): " wd1))
|
|
(if (not (word? wd2))
|
|
(begin
|
|
(whoops "Invalid second argument to BEFORE? (not a word): " wd2))
|
|
(begin (string<? (word->string wd1) (word->string wd2))))))))
|
|
|
|
(define-values
|
|
(filter)
|
|
(let-values (((null?) null?)
|
|
((car) car)
|
|
((cons) cons)
|
|
((cdr) cdr)
|
|
((not) not)
|
|
((procedure?) procedure?)
|
|
((whoops) whoops)
|
|
((list?) list?))
|
|
(lambda (pred l)
|
|
(letrec-values (((real-filter)
|
|
(lambda (l)
|
|
(if (null? l)
|
|
(begin '())
|
|
(if (pred (car l))
|
|
(begin (cons (car l) (real-filter (cdr l))))
|
|
(begin (real-filter (cdr l))))))))
|
|
(if (not (procedure? pred))
|
|
(begin
|
|
(whoops
|
|
"Invalid first argument to FILTER (not a procedure): "
|
|
pred))
|
|
(if (not (list? l))
|
|
(begin
|
|
(whoops "Invalid second argument to FILTER (not a list): " l))
|
|
(begin (real-filter l))))))))
|
|
|
|
(define-values
|
|
(keep)
|
|
(let-values (((+) simply-scheme:+)
|
|
((=) simply-scheme:=)
|
|
((pair?) pair?)
|
|
((substring) substring)
|
|
((char->word) char->word)
|
|
((string-ref) string-ref)
|
|
((string-set!) string-set!)
|
|
((word->string) word->string)
|
|
((string-length) string-length)
|
|
((string->word) string->word)
|
|
((make-string) make-string)
|
|
((procedure?) procedure?)
|
|
((whoops) whoops)
|
|
((word?) word?)
|
|
((null?) null?))
|
|
(lambda (pred w-or-s)
|
|
(letrec-values (((keep-string)
|
|
(lambda (in i out out-len len)
|
|
(if (= i len)
|
|
(begin (substring out 0 out-len))
|
|
(if (pred (char->word (string-ref in i)))
|
|
(begin
|
|
(string-set! out out-len (string-ref in i))
|
|
(keep-string in (+ i 1) out (+ out-len 1) len))
|
|
(begin
|
|
(keep-string in (+ i 1) out out-len len))))))
|
|
((keep-word)
|
|
(lambda (wd)
|
|
(let-values (((string) (word->string wd)))
|
|
(let-values (((len) (string-length string)))
|
|
(string->word
|
|
(keep-string
|
|
string
|
|
0
|
|
(make-string len)
|
|
0
|
|
len)))))))
|
|
(if (not (procedure? pred))
|
|
(begin
|
|
(whoops "Invalid first argument to KEEP (not a procedure): " pred))
|
|
(if (pair? w-or-s)
|
|
(begin (filter pred w-or-s))
|
|
(if (word? w-or-s)
|
|
(begin (keep-word w-or-s))
|
|
(if (null? w-or-s)
|
|
(begin '())
|
|
(begin
|
|
(whoops
|
|
"Bad second argument to KEEP (not a word or sentence): "
|
|
w-or-s))))))))))
|
|
|
|
(define-values
|
|
(appearances)
|
|
(let-values (((count) count) ((keep) keep) ((equal?) simply-scheme:equal?))
|
|
(lambda (item aggregate)
|
|
(count (keep (lambda (element) (equal? item element)) aggregate)))))
|
|
|
|
(define-values
|
|
(every)
|
|
(let-values (((=) simply-scheme:=)
|
|
((+) simply-scheme:+)
|
|
((se) se)
|
|
((char->word) char->word)
|
|
((string-ref) string-ref)
|
|
((empty?) empty?)
|
|
((first) first)
|
|
((bf) bf)
|
|
((not) not)
|
|
((procedure?) procedure?)
|
|
((whoops) whoops)
|
|
((word?) word?)
|
|
((word->string) word->string)
|
|
((string-length) string-length))
|
|
(lambda (fn stuff)
|
|
(letrec-values (((string-every)
|
|
(lambda (string i length)
|
|
(if (= i length)
|
|
'()
|
|
(se
|
|
(fn (char->word (string-ref string i)))
|
|
(string-every string (+ i 1) length)))))
|
|
((sent-every)
|
|
(lambda (sent)
|
|
(if (empty? sent)
|
|
sent
|
|
(se (fn (first sent)) (sent-every (bf sent)))))))
|
|
(if (not (procedure? fn))
|
|
(begin
|
|
(whoops "Invalid first argument to EVERY (not a procedure):" fn))
|
|
(if (word? stuff)
|
|
(begin
|
|
(let-values (((string) (word->string stuff)))
|
|
(string-every string 0 (string-length string))))
|
|
(begin (sent-every stuff))))))))
|
|
|
|
(define-values
|
|
(accumulate)
|
|
(let-values (((not) not)
|
|
((empty?) empty?)
|
|
((bf) bf)
|
|
((first) first)
|
|
((procedure?) procedure?)
|
|
((whoops) whoops)
|
|
((member) member)
|
|
((list) list))
|
|
(lambda (combiner stuff)
|
|
(letrec-values (((real-accumulate)
|
|
(lambda (stuff)
|
|
(if (empty? (bf stuff))
|
|
(first stuff)
|
|
(combiner
|
|
(first stuff)
|
|
(real-accumulate (bf stuff)))))))
|
|
(if (not (procedure? combiner))
|
|
(begin
|
|
(whoops
|
|
"Invalid first argument to ACCUMULATE (not a procedure):"
|
|
combiner))
|
|
(if (not (empty? stuff))
|
|
(begin (real-accumulate stuff))
|
|
(if (member
|
|
combiner
|
|
(list simply-scheme:+ simply-scheme:* word se))
|
|
(begin (combiner))
|
|
(begin
|
|
(whoops
|
|
"Can't accumulate empty input with that combiner")))))))))
|
|
|
|
(define-values
|
|
(reduce)
|
|
(let-values (((null?) null?)
|
|
((cdr) cdr)
|
|
((car) car)
|
|
((not) not)
|
|
((procedure?) procedure?)
|
|
((whoops) whoops)
|
|
((member) member)
|
|
((list) list))
|
|
(lambda (combiner stuff)
|
|
(letrec-values (((real-reduce)
|
|
(lambda (stuff)
|
|
(if (null? (cdr stuff))
|
|
(car stuff)
|
|
(combiner (car stuff) (real-reduce (cdr stuff)))))))
|
|
(if (not (procedure? combiner))
|
|
(begin
|
|
(whoops
|
|
"Invalid first argument to REDUCE (not a procedure):"
|
|
combiner))
|
|
(if (not (null? stuff))
|
|
(begin (real-reduce stuff))
|
|
(if (member
|
|
combiner
|
|
(list simply-scheme:+ simply-scheme:* word se append))
|
|
(begin (combiner))
|
|
(begin
|
|
(whoops "Can't reduce empty input with that combiner")))))))))
|
|
|
|
(define-values
|
|
(repeated)
|
|
(let-values (((=) simply-scheme:=) ((-) simply-scheme:-))
|
|
(lambda (fn number)
|
|
(if (= number 0)
|
|
(lambda (x) x)
|
|
(lambda (x) ((repeated fn (- number 1)) (fn x)))))))
|
|
|
|
(define-values (make-node) cons)
|
|
|
|
(define-values (datum) car)
|
|
|
|
(define-values (children) cdr)
|
|
|
|
(define-values
|
|
(show)
|
|
(let-values (((=) simply-scheme:=)
|
|
((length) length)
|
|
((display) display)
|
|
((car) car)
|
|
((newline) newline)
|
|
((not) not)
|
|
#;((output-port?) output-port?)
|
|
((apply) apply)
|
|
((whoops) whoops))
|
|
(lambda args
|
|
(if (= (length args) 1)
|
|
(begin (display (car args)) (newline))
|
|
(if (= (length args) 2)
|
|
(begin
|
|
#;(if (not (output-port? (car (cdr args))))
|
|
(whoops
|
|
"Invalid second argument to SHOW (not an output port): "
|
|
(car (cdr args)))
|
|
(void))
|
|
(apply display args)
|
|
(newline (car (cdr args))))
|
|
(begin
|
|
(whoops "Incorrect number of arguments to procedure SHOW")))))))
|
|
|
|
(define-values
|
|
(show-line)
|
|
(let-values (((>=) simply-scheme:>=)
|
|
((length) length)
|
|
((whoops) whoops)
|
|
((null?) null?)
|
|
((current-output-port) current-output-port)
|
|
((car) car)
|
|
((not) not)
|
|
((list?) list?)
|
|
((display) display)
|
|
((for-each) for-each)
|
|
((cdr) cdr)
|
|
((newline) newline))
|
|
(lambda (line . args)
|
|
(if (>= (length args) 2)
|
|
(whoops "Too many arguments to show-line")
|
|
(let-values (((port)
|
|
(if (null? args) (current-output-port) (car args))))
|
|
(if (not (list? line))
|
|
(begin (whoops "Invalid argument to SHOW-LINE (not a list):" line))
|
|
(if (null? line)
|
|
(begin #f)
|
|
(begin
|
|
(display (car line) port)
|
|
(for-each
|
|
(lambda (wd) (display " " port) (display wd port))
|
|
(cdr line)))))
|
|
(newline port))))))
|
|
|
|
#;(set! simply-scheme:read-string
|
|
(let-values (((read-char) read-char)
|
|
((eqv?) eqv?)
|
|
((apply) apply)
|
|
((string-append) string-append)
|
|
((substring) substring)
|
|
((reverse) reverse)
|
|
((cons) cons)
|
|
((>=) simply-scheme:>=)
|
|
((+) simply-scheme:+)
|
|
((string-set!) string-set!)
|
|
((length) length)
|
|
((whoops) whoops)
|
|
((null?) null?)
|
|
((current-input-port) current-input-port)
|
|
((car) car)
|
|
((cdr) cdr)
|
|
((eof-object?) eof-object?)
|
|
((list) list)
|
|
((make-string) make-string)
|
|
((peek-char) peek-char))
|
|
(letrec-values (((read-string-helper)
|
|
(lambda (chars all-length chunk-length port)
|
|
(let-values (((char) (read-char port))
|
|
((string) (car chars)))
|
|
(if (let-values (((or-part) (eof-object? char)))
|
|
(if or-part or-part (eqv? char #\newline)))
|
|
(begin
|
|
(apply
|
|
string-append
|
|
(reverse
|
|
(cons
|
|
(substring (car chars) 0 chunk-length)
|
|
(cdr chars)))))
|
|
(if (>= chunk-length 80)
|
|
(begin
|
|
(let-values (((newstring) (make-string 80)))
|
|
(string-set! newstring 0 char)
|
|
(read-string-helper
|
|
(cons newstring chars)
|
|
(+ all-length 1)
|
|
1
|
|
port)))
|
|
(begin
|
|
(string-set! string chunk-length char)
|
|
(read-string-helper
|
|
chars
|
|
(+ all-length 1)
|
|
(+ chunk-length 1)
|
|
port))))))))
|
|
(lambda args
|
|
(if (>= (length args) 2)
|
|
(whoops "Too many arguments to read-string")
|
|
(let-values (((port)
|
|
(if (null? args) (current-input-port) (car args))))
|
|
(if (eof-object? (peek-char port))
|
|
(read-char port)
|
|
(read-string-helper (list (make-string 80)) 0 0 port))))))))
|
|
|
|
#;(set! simply-scheme:read-line
|
|
(let-values (((=) simply-scheme:=)
|
|
((list) list)
|
|
((string->word) string->word)
|
|
((substring) substring)
|
|
((char-whitespace?) char-whitespace?)
|
|
((string-ref) string-ref)
|
|
((+) simply-scheme:+)
|
|
((string-length) string-length)
|
|
((apply) apply)
|
|
((read-string) simply-scheme:read-string))
|
|
(lambda args
|
|
(letrec-values (((tokenize)
|
|
(lambda (string)
|
|
(letrec-values (((helper)
|
|
(lambda (i start len)
|
|
(if (= i len)
|
|
(begin
|
|
(if (= i start)
|
|
'()
|
|
(list
|
|
(string->word
|
|
(substring
|
|
string
|
|
start
|
|
i)))))
|
|
(if (char-whitespace?
|
|
(string-ref string i))
|
|
(begin
|
|
(if (= i start)
|
|
(helper
|
|
(+ i 1)
|
|
(+ i 1)
|
|
len)
|
|
(cons
|
|
(string->word
|
|
(substring
|
|
string
|
|
start
|
|
i))
|
|
(helper
|
|
(+ i 1)
|
|
(+ i 1)
|
|
len))))
|
|
(begin
|
|
(helper
|
|
(+ i 1)
|
|
start
|
|
len)))))))
|
|
(if (eof-object? string)
|
|
string
|
|
(helper 0 0 (string-length string)))))))
|
|
(tokenize (apply read-string args))))))
|
|
|
|
(define-values (*the-open-inports*) '())
|
|
|
|
(define-values (*the-open-outports*) '())
|
|
|
|
(define-values
|
|
(align)
|
|
(let-values (((<) simply-scheme:<)
|
|
((abs) simply-scheme:abs)
|
|
((*) simply-scheme:*)
|
|
((expt) simply-scheme:expt)
|
|
((>=) simply-scheme:>=)
|
|
((-) simply-scheme:-)
|
|
((+) simply-scheme:+)
|
|
((=) simply-scheme:=)
|
|
((null?) null?)
|
|
((car) car)
|
|
((round) simply-scheme:round)
|
|
((number->string) simply-scheme:number->string)
|
|
((string-length) string-length)
|
|
((string-append) string-append)
|
|
((make-string) make-string)
|
|
((substring) substring)
|
|
((string-set!) string-set!)
|
|
((number?) simply-scheme:number?)
|
|
((word->string) word->string))
|
|
(lambda (obj width . rest)
|
|
(letrec-values (((align-number)
|
|
(lambda (obj width rest)
|
|
(let-values (((sign) (< obj 0)))
|
|
(let-values (((num) (abs obj)))
|
|
(let-values (((prec)
|
|
(if (null? rest) 0 (car rest))))
|
|
(let-values (((big)
|
|
(round (* num (expt 10 prec)))))
|
|
(let-values (((cvt0) (number->string big)))
|
|
(let-values (((cvt)
|
|
(if (< num 1)
|
|
(string-append "0" cvt0)
|
|
cvt0)))
|
|
(let-values (((pos-str)
|
|
(if (>=
|
|
(string-length cvt0)
|
|
prec)
|
|
cvt
|
|
(string-append
|
|
(make-string
|
|
(-
|
|
prec
|
|
(string-length cvt0))
|
|
#\0)
|
|
cvt))))
|
|
(let-values (((string)
|
|
(if sign
|
|
(string-append
|
|
"-"
|
|
pos-str)
|
|
pos-str)))
|
|
(let-values (((length)
|
|
(+
|
|
(string-length string)
|
|
(if (= prec 0) 0 1))))
|
|
(let-values (((left)
|
|
(-
|
|
length
|
|
(+ 1 prec))))
|
|
(let-values (((result)
|
|
(if (= prec 0)
|
|
string
|
|
(string-append
|
|
(substring
|
|
string
|
|
0
|
|
left)
|
|
"."
|
|
(substring
|
|
string
|
|
left
|
|
(-
|
|
length
|
|
1))))))
|
|
(if (= length width)
|
|
(begin result)
|
|
(if (< length width)
|
|
(begin
|
|
(string-append
|
|
(make-string
|
|
(- width length)
|
|
#\space)
|
|
result))
|
|
(begin
|
|
(let-values (((new)
|
|
(substring
|
|
result
|
|
0
|
|
width)))
|
|
(string-set!
|
|
new
|
|
(- width 1)
|
|
#\+)
|
|
new)))))))))))))))))
|
|
((align-word)
|
|
(lambda (string)
|
|
(let-values (((length) (string-length string)))
|
|
(if (= length width)
|
|
(begin string)
|
|
(if (< length width)
|
|
(begin
|
|
(string-append
|
|
string
|
|
(make-string (- width length) #\space)))
|
|
(begin
|
|
(let-values (((new)
|
|
(substring string 0 width)))
|
|
(string-set! new (- width 1) #\+)
|
|
new))))))))
|
|
(if (number? obj)
|
|
(align-number obj width rest)
|
|
(align-word (word->string obj)))))))
|
|
|
|
#;(set! simply-scheme:open-output-file
|
|
(let-values (((oof) simply-scheme:open-output-file) ((cons) cons))
|
|
(lambda (filename)
|
|
(let-values (((port) (oof filename)))
|
|
(set! *the-open-outports*
|
|
(#%app cons port (#%top . *the-open-outports*)))
|
|
port))))
|
|
|
|
#;(set! simply-scheme:open-input-file
|
|
(let-values (((oif) simply-scheme:open-input-file) ((cons) cons))
|
|
(lambda (filename)
|
|
(let-values (((port) (oif filename)))
|
|
(set! *the-open-inports*
|
|
(#%app cons port (#%top . *the-open-inports*)))
|
|
port))))
|
|
|
|
(define-values
|
|
(remove)
|
|
(let-values (((null?) null?)
|
|
((cdr) cdr)
|
|
((eq?) eq?)
|
|
((car) car))
|
|
(lambda (thing lst)
|
|
(letrec-values (((r)
|
|
(lambda (prev)
|
|
(if (null? (cdr prev))
|
|
(begin lst)
|
|
(if (eq? thing (car (cdr prev)))
|
|
(begin (cons (car prev)
|
|
(cdr (cdr prev))))
|
|
(begin (cons (car prev)
|
|
(r (cdr prev)))))))))
|
|
(if (null? lst)
|
|
(begin lst)
|
|
(if (eq? thing (car lst))
|
|
(begin (cdr lst))
|
|
(begin (r lst))))))))
|
|
|
|
#;(set! simply-scheme:close-input-port
|
|
(let-values (((cip) simply-scheme:close-input-port) ((remove) remove))
|
|
(lambda (port)
|
|
(set! *the-open-inports*
|
|
(#%app remove port (#%top . *the-open-inports*)))
|
|
(cip port))))
|
|
|
|
#;(set! simply-scheme:close-output-port
|
|
(let-values (((cop) simply-scheme:close-output-port) ((remove) remove))
|
|
(lambda (port)
|
|
(set! *the-open-outports*
|
|
(#%app remove port (#%top . *the-open-outports*)))
|
|
(cop port))))
|
|
|
|
#;(define-values
|
|
(close-all-ports)
|
|
(let-values (((for-each) for-each)
|
|
((close-input-port) simply-scheme:close-input-port)
|
|
((close-output-port) simply-scheme:close-output-port))
|
|
(lambda ()
|
|
(for-each close-input-port *the-open-inports*)
|
|
(for-each close-output-port *the-open-outports*)
|
|
'closed)))
|
|
|
|
(define-values
|
|
(maybe-num)
|
|
(let-values (((string?) string?) ((string->number) string->number))
|
|
(lambda (arg)
|
|
(if (string? arg)
|
|
(let-values (((num) (string->number arg))) (if num num arg))
|
|
arg))))
|
|
|
|
(define-values
|
|
(logoize)
|
|
(let-values (((apply) apply) ((map) map) ((maybe-num) maybe-num))
|
|
(lambda (fn) (lambda args (apply fn (map maybe-num args))))))
|
|
|
|
(define-values
|
|
(logoize-1)
|
|
(let-values (((maybe-num) maybe-num))
|
|
(lambda (fn) (lambda (x) (fn (maybe-num x))))))
|
|
|
|
(define-values
|
|
(logoize-2)
|
|
(let-values (((maybe-num) maybe-num))
|
|
(lambda (fn) (lambda (x y) (fn (maybe-num x) (maybe-num y))))))
|
|
|
|
(define-values
|
|
(strings-are-numbers)
|
|
(let-values (((are-they?) #f)
|
|
((real-*) simply-scheme:*)
|
|
((real-+) simply-scheme:+)
|
|
((real--) simply-scheme:-)
|
|
((real-/) simply-scheme:/)
|
|
((real-<) simply-scheme:<)
|
|
((real-<=) simply-scheme:<=)
|
|
((real-=) simply-scheme:=)
|
|
((real->) simply-scheme:>)
|
|
((real->=) simply-scheme:>=)
|
|
((real-abs) simply-scheme:abs)
|
|
((real-acos) simply-scheme:acos)
|
|
((real-asin) simply-scheme:asin)
|
|
((real-atan) simply-scheme:atan)
|
|
((real-ceiling) simply-scheme:ceiling)
|
|
((real-cos) simply-scheme:cos)
|
|
((real-even?) simply-scheme:even?)
|
|
((real-exp) simply-scheme:exp)
|
|
((real-expt) simply-scheme:expt)
|
|
((real-floor) simply-scheme:floor)
|
|
((real-align) align)
|
|
((real-gcd) simply-scheme:gcd)
|
|
((real-integer?) simply-scheme:integer?)
|
|
((real-item) item)
|
|
((real-lcm) simply-scheme:lcm)
|
|
((real-list-ref) simply-scheme:list-ref)
|
|
((real-log) simply-scheme:log)
|
|
((real-make-vector) simply-scheme:make-vector)
|
|
((real-max) simply-scheme:max)
|
|
((real-min) simply-scheme:min)
|
|
((real-modulo) simply-scheme:modulo)
|
|
((real-negative?) simply-scheme:negative?)
|
|
((real-number?) simply-scheme:number?)
|
|
((real-odd?) simply-scheme:odd?)
|
|
((real-positive?) simply-scheme:positive?)
|
|
((real-quotient) simply-scheme:quotient)
|
|
((real-random) simply-scheme:random)
|
|
((real-remainder) simply-scheme:remainder)
|
|
((real-repeated) repeated)
|
|
((real-round) simply-scheme:round)
|
|
((real-sin) simply-scheme:sin)
|
|
((real-sqrt) simply-scheme:sqrt)
|
|
((real-tan) simply-scheme:tan)
|
|
((real-truncate) simply-scheme:truncate)
|
|
((real-vector-ref) simply-scheme:vector-ref)
|
|
((real-vector-set!) simply-scheme:vector-set!)
|
|
((real-zero?) simply-scheme:zero?)
|
|
((maybe-num) maybe-num)
|
|
((number->string) simply-scheme:number->string)
|
|
((cons) cons)
|
|
((car) car)
|
|
((cdr) cdr)
|
|
((eq?) eq?)
|
|
((show) show)
|
|
((logoize) logoize)
|
|
((logoize-1) logoize-1)
|
|
((logoize-2) logoize-2)
|
|
((not) not)
|
|
((whoops) whoops))
|
|
(lambda (yesno)
|
|
(if (if are-they? (eq? yesno #t) #f)
|
|
(begin (show "Strings are already numbers"))
|
|
(if (eq? yesno #t)
|
|
(begin
|
|
(set! are-they? (#%datum . #t))
|
|
(set! simply-scheme:* (logoize real-*))
|
|
(set! simply-scheme:+ (logoize real-+))
|
|
(set! simply-scheme:- (logoize real--))
|
|
(set! simply-scheme:/ (logoize real-/))
|
|
(set! simply-scheme:< (logoize real-<))
|
|
(set! simply-scheme:<= (logoize real-<=))
|
|
(set! simply-scheme:= (logoize real-=))
|
|
(set! simply-scheme:> (logoize real->))
|
|
(set! simply-scheme:>= (logoize real->=))
|
|
(set! simply-scheme:abs (logoize-1 real-abs))
|
|
(set! simply-scheme:acos (logoize-1 real-acos))
|
|
(set! simply-scheme:asin (logoize-1 real-asin))
|
|
(set! simply-scheme:atan (logoize real-atan))
|
|
(set! simply-scheme:ceiling (logoize-1 real-ceiling))
|
|
(set! simply-scheme:cos (logoize-1 real-cos))
|
|
(set! simply-scheme:even? (logoize-1 real-even?))
|
|
(set! simply-scheme:exp (logoize-1 real-exp))
|
|
(set! simply-scheme:expt (logoize-2 real-expt))
|
|
(set! simply-scheme:floor (logoize-1 real-floor))
|
|
(set! align (#%app logoize (#%top . align)))
|
|
(set! simply-scheme:gcd (logoize real-gcd))
|
|
(set! simply-scheme:integer? (logoize-1 real-integer?))
|
|
(set! item
|
|
(lambda (n stuff) (#%app real-item (#%app maybe-num n) stuff)))
|
|
(set! simply-scheme:lcm (logoize real-lcm))
|
|
(set! simply-scheme:list-ref
|
|
(lambda (lst k) (real-list-ref lst (maybe-num k))))
|
|
(set! simply-scheme:log (logoize-1 real-log))
|
|
(set! simply-scheme:max (logoize real-max))
|
|
(set! simply-scheme:min (logoize real-min))
|
|
(set! simply-scheme:modulo (logoize-2 real-modulo))
|
|
(set! simply-scheme:negative? (logoize-1 real-negative?))
|
|
(set! simply-scheme:number? (logoize-1 real-number?))
|
|
(set! simply-scheme:odd? (logoize-1 real-odd?))
|
|
(set! simply-scheme:positive? (logoize-1 real-positive?))
|
|
(set! simply-scheme:quotient (logoize-2 real-quotient))
|
|
(set! simply-scheme:random (logoize real-random))
|
|
(set! simply-scheme:remainder (logoize-2 real-remainder))
|
|
(set! simply-scheme:round (logoize-1 real-round))
|
|
(set! simply-scheme:sin (logoize-1 real-sin))
|
|
(set! simply-scheme:sqrt (logoize-1 real-sqrt))
|
|
(set! simply-scheme:tan (logoize-1 real-tan))
|
|
(set! simply-scheme:truncate (logoize-1 real-truncate))
|
|
(set! simply-scheme:zero? (logoize-1 real-zero?))
|
|
(set! simply-scheme:vector-ref
|
|
(lambda (vec i) (real-vector-ref vec (maybe-num i))))
|
|
(set! simply-scheme:vector-set!
|
|
(lambda (vec i val) (real-vector-set! vec (maybe-num i) val)))
|
|
(set! simply-scheme:make-vector
|
|
(lambda (num . args)
|
|
(apply real-make-vector (cons (maybe-num num) args))))
|
|
(set! simply-scheme:list-ref
|
|
(lambda (lst i) (real-list-ref lst (maybe-num i))))
|
|
(set! repeated
|
|
(lambda (fn n) (#%app real-repeated fn (#%app maybe-num n)))))
|
|
(if (if (not are-they?) (not yesno) #f)
|
|
(begin (show "Strings are already not numbers"))
|
|
(if (not yesno)
|
|
(begin
|
|
(set! are-they? (#%datum . #f))
|
|
(set! simply-scheme:* real-*)
|
|
(set! simply-scheme:+ real-+)
|
|
(set! simply-scheme:- real--)
|
|
(set! simply-scheme:/ real-/)
|
|
(set! simply-scheme:< real-<)
|
|
(set! simply-scheme:<= real-<=)
|
|
(set! simply-scheme:= real-=)
|
|
(set! simply-scheme:> real->)
|
|
(set! simply-scheme:>= real->=)
|
|
(set! simply-scheme:abs real-abs)
|
|
(set! simply-scheme:acos real-acos)
|
|
(set! simply-scheme:asin real-asin)
|
|
(set! simply-scheme:atan real-atan)
|
|
(set! simply-scheme:ceiling real-ceiling)
|
|
(set! simply-scheme:cos real-cos)
|
|
(set! simply-scheme:even? real-even?)
|
|
(set! simply-scheme:exp real-exp)
|
|
(set! simply-scheme:expt real-expt)
|
|
(set! simply-scheme:floor real-floor)
|
|
(set! align real-align)
|
|
(set! simply-scheme:gcd real-gcd)
|
|
(set! simply-scheme:integer? real-integer?)
|
|
(set! item real-item)
|
|
(set! simply-scheme:lcm real-lcm)
|
|
(set! simply-scheme:list-ref real-list-ref)
|
|
(set! simply-scheme:log real-log)
|
|
(set! simply-scheme:max real-max)
|
|
(set! simply-scheme:min real-min)
|
|
(set! simply-scheme:modulo real-modulo)
|
|
(set! simply-scheme:odd? real-odd?)
|
|
(set! simply-scheme:quotient real-quotient)
|
|
(set! simply-scheme:random real-random)
|
|
(set! simply-scheme:remainder real-remainder)
|
|
(set! simply-scheme:round real-round)
|
|
(set! simply-scheme:sin real-sin)
|
|
(set! simply-scheme:sqrt real-sqrt)
|
|
(set! simply-scheme:tan real-tan)
|
|
(set! simply-scheme:truncate real-truncate)
|
|
(set! simply-scheme:zero? real-zero?)
|
|
(set! simply-scheme:positive? real-positive?)
|
|
(set! simply-scheme:negative? real-negative?)
|
|
(set! simply-scheme:number? real-number?)
|
|
(set! simply-scheme:vector-ref real-vector-ref)
|
|
(set! simply-scheme:vector-set! real-vector-set!)
|
|
(set! simply-scheme:make-vector real-make-vector)
|
|
(set! simply-scheme:list-ref real-list-ref)
|
|
(set! item real-item)
|
|
(set! repeated real-repeated))
|
|
(begin (whoops "Strings-are-numbers: give a #t or a #f"))))))
|
|
are-they?)))
|
|
|
|
(void (strings-are-numbers #t))
|
|
(require (for-syntax racket/base)
|
|
(prefix-in whalesong: whalesong/lang/base))
|
|
|
|
(provide (except-out
|
|
(filtered-out (lambda (name)
|
|
(and (regexp-match? #rx"^whalesong:" name)
|
|
(regexp-replace #rx"^whalesong:" name "")))
|
|
(all-from-out whalesong/lang/base))
|
|
whalesong:*
|
|
whalesong:+
|
|
whalesong:-
|
|
whalesong:/
|
|
whalesong:<
|
|
whalesong:<=
|
|
whalesong:=
|
|
whalesong:>
|
|
whalesong:>=
|
|
whalesong:abs
|
|
whalesong:acos
|
|
whalesong:asin
|
|
whalesong:atan
|
|
whalesong:ceiling
|
|
whalesong:count
|
|
#;close-input-port
|
|
#;close-output-port
|
|
whalesong:cos
|
|
whalesong:equal?
|
|
whalesong:even?
|
|
whalesong:exp
|
|
whalesong:expt
|
|
whalesong:floor
|
|
whalesong:gcd
|
|
whalesong:integer?
|
|
whalesong:lcm
|
|
whalesong:list-ref
|
|
whalesong:log
|
|
whalesong:make-vector
|
|
whalesong:max
|
|
whalesong:min
|
|
whalesong:modulo
|
|
whalesong:negative?
|
|
whalesong:number->string
|
|
whalesong:number?
|
|
whalesong:odd?
|
|
#;open-input-file
|
|
#;open-output-file
|
|
whalesong:positive?
|
|
whalesong:quotient
|
|
whalesong:random
|
|
#;read-line
|
|
#;read-string
|
|
whalesong:remainder
|
|
whalesong:round
|
|
whalesong:sin
|
|
whalesong:sqrt
|
|
whalesong:tan
|
|
whalesong:truncate
|
|
whalesong:vector-ref
|
|
whalesong:vector-set!
|
|
whalesong:zero?)
|
|
|
|
|
|
|
|
*the-open-inports*
|
|
*the-open-outports*
|
|
|
|
|
|
;; The rest of these are the bindings that are defined
|
|
;; in this language module.
|
|
accumulate
|
|
align
|
|
appearances
|
|
before?
|
|
bf
|
|
bl
|
|
butfirst
|
|
butlast
|
|
char->word
|
|
char-rank
|
|
children
|
|
|
|
#;close-all-ports
|
|
count
|
|
#|
|
|
datum
|
|
empty?
|
|
every
|
|
filter
|
|
first
|
|
item
|
|
keep
|
|
last
|
|
logoize
|
|
logoize-1
|
|
logoize-2
|
|
make-node
|
|
maybe-num
|
|
member?
|
|
reduce
|
|
remove
|
|
repeated
|
|
se
|
|
sentence
|
|
sentence?
|
|
show
|
|
show-line
|
|
string->word
|
|
strings-are-numbers
|
|
whoops
|
|
word
|
|
word->string
|
|
word?
|
|
|#
|
|
(rename-out [simply-scheme:* *]
|
|
[simply-scheme:+ +]
|
|
[simply-scheme:- -]
|
|
[simply-scheme:/ /]
|
|
[simply-scheme:< <]
|
|
[simply-scheme:<= <=]
|
|
[simply-scheme:= =]
|
|
[simply-scheme:> >]
|
|
[simply-scheme:>= >=]
|
|
[simply-scheme:abs abs]
|
|
[simply-scheme:acos acos]
|
|
[simply-scheme:asin asin]
|
|
[simply-scheme:atan atan]
|
|
[simply-scheme:ceiling ceiling]
|
|
#;[simply-scheme:close-input-port close-input-port]
|
|
#;[simply-scheme:close-output-port close-output-port]
|
|
[simply-scheme:cos cos]
|
|
[simply-scheme:equal? equal?]
|
|
[simply-scheme:even? even?]
|
|
[simply-scheme:exp exp]
|
|
[simply-scheme:expt expt]
|
|
[simply-scheme:floor floor]
|
|
[simply-scheme:gcd gcd]
|
|
[simply-scheme:integer? integer?]
|
|
[simply-scheme:lcm lcm]
|
|
[simply-scheme:list-ref list-ref]
|
|
[simply-scheme:log log]
|
|
[simply-scheme:make-vector make-vector]
|
|
[simply-scheme:max max]
|
|
[simply-scheme:min min]
|
|
[simply-scheme:modulo modulo]
|
|
[simply-scheme:negative? negative?]
|
|
[simply-scheme:number->string number->string]
|
|
[simply-scheme:number? number?]
|
|
[simply-scheme:odd? odd?]
|
|
#;[simply-scheme:open-input-file open-input-file]
|
|
#;[simply-scheme:open-output-file open-output-file]
|
|
[simply-scheme:positive? positive?]
|
|
[simply-scheme:quotient quotient]
|
|
[simply-scheme:random random]
|
|
#;[simply-scheme:read-line read-line]
|
|
#;[simply-scheme:read-string read-string]
|
|
[simply-scheme:remainder remainder]
|
|
[simply-scheme:round round]
|
|
[simply-scheme:sin sin]
|
|
[simply-scheme:sqrt sqrt]
|
|
[simply-scheme:tan tan]
|
|
[simply-scheme:truncate truncate]
|
|
[simply-scheme:vector-ref vector-ref]
|
|
[simply-scheme:vector-set! vector-set!]
|
|
[simply-scheme:zero? zero?])) |