adding bindings for the teaching primitives
This commit is contained in:
Danny Yoo
parent
a66d15e4e4
commit
d8edb171dc
132
cs019/cs019.rkt
132
cs019/cs019.rkt
|
|
@ -1,4 +1,4 @@
|
|||
#lang s-exp "../lang/kernel.rkt"
|
||||
#lang s-exp "../lang/base.rkt"
|
||||
|
||||
;; Like the big whalesong language, but with additional ASL restrictions.
|
||||
|
||||
|
|
@ -23,7 +23,19 @@
|
|||
case
|
||||
when
|
||||
unless
|
||||
member))
|
||||
member)
|
||||
|
||||
string-ith
|
||||
replicate
|
||||
int->string
|
||||
string->int
|
||||
explode
|
||||
implode
|
||||
string-numeric?
|
||||
string-alphabetic?
|
||||
string-whitespace?
|
||||
string-upper-case?
|
||||
string-lower-case?)
|
||||
|
||||
|
||||
(require "../image.rkt")
|
||||
|
|
@ -454,6 +466,122 @@
|
|||
|
||||
|
||||
|
||||
|
||||
(define 1-LET "1-letter string")
|
||||
(define 1-LETTER (format "~a" 1-LET))
|
||||
(define 1-LETTER* (format "list of ~as" 1-LET))
|
||||
(define NAT "natural number")
|
||||
|
||||
;; Symbol Any -> Boolean
|
||||
;; is this a 1-letter string?
|
||||
(define (1-letter? tag s)
|
||||
(unless (string? s) (err tag "expected a ~a, but received a string: ~e" 1-LETTER s))
|
||||
(= (string-length s) 1))
|
||||
|
||||
;; Symbol Any -> Boolean
|
||||
;; is s a list of 1-letter strings
|
||||
;; effect: not a list, not a list of strings
|
||||
(define (1-letter*? tag s)
|
||||
(unless (list? s) (err tag "expected a ~a, but received: ~e" 1-LETTER* s))
|
||||
(for-each
|
||||
(lambda (c)
|
||||
(unless (string? c) (err tag "expected a ~a, but received: ~e" 1-LETTER* c)))
|
||||
s)
|
||||
(andmap (compose (lambda (x) (= x 1)) string-length) s))
|
||||
|
||||
|
||||
(define (err tag msg-format . args)
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(apply format (string-append (symbol->string tag) ": " msg-format) args)
|
||||
(current-continuation-marks))))
|
||||
|
||||
(define (a-or-an after)
|
||||
(if (member (string-ref (format "~a" after) 0) '(#\a #\e #\i #\o #\u))
|
||||
"an" "a"))
|
||||
|
||||
(define cerr
|
||||
(case-lambda
|
||||
[(tag check-result format-msg actual)
|
||||
(unless check-result
|
||||
(err tag (string-append "expected " (a-or-an format-msg) " " format-msg ", but received ~e") actual))]
|
||||
[(tag check-result format-msg actual snd)
|
||||
(unless check-result
|
||||
(err tag (string-append "expected " (a-or-an format-msg) " " format-msg " for the ~a argument, but received ~e")
|
||||
snd actual))]))
|
||||
|
||||
(define string-ith
|
||||
(lambda (s n)
|
||||
(define f "exact integer in [0, length of the given string]")
|
||||
(cerr 'string-ith (string? s) "string" s "first")
|
||||
(cerr 'string-ith (and (number? n) (integer? n) (>= n 0)) NAT n "second")
|
||||
(let ([l (string-length s)])
|
||||
(cerr 'string-ith (< n l) f n "second"))
|
||||
(string (string-ref s n))))
|
||||
|
||||
|
||||
|
||||
(define replicate
|
||||
(lambda (n s1)
|
||||
(cerr 'replicate (and (number? n) (exact-integer? n) (>= n 0)) NAT n)
|
||||
(cerr 'replicate (string? s1) "string" s1)
|
||||
(apply string-append (build-list n (lambda (i) s1)))))
|
||||
|
||||
(define int->string
|
||||
(lambda (i)
|
||||
(cerr 'int->string
|
||||
(and (exact-integer? i) (or (<= 0 i 55295) (<= 57344 i 1114111)))
|
||||
"exact integer in [0,55295] or [57344 1114111]"
|
||||
i)
|
||||
(string (integer->char i))))
|
||||
|
||||
(define string->int
|
||||
(lambda (s)
|
||||
(cerr 'string->int (1-letter? 'string->int s) 1-LETTER s)
|
||||
(char->integer (string-ref s 0))))
|
||||
|
||||
|
||||
(define explode
|
||||
(lambda (s)
|
||||
(cerr 'explode (string? s) "string" s)
|
||||
(map string (string->list s))))
|
||||
|
||||
(define implode
|
||||
(lambda (los)
|
||||
(cerr 'implode (1-letter*? 'implode los) 1-LETTER* los)
|
||||
(apply string-append los)))
|
||||
|
||||
|
||||
|
||||
(define string-numeric?
|
||||
;; is this: (number? (string->number s)) enough?
|
||||
(lambda (s1)
|
||||
(cerr 'string-numeric? (string? s1) "string" s1)
|
||||
(andmap char-numeric? (string->list s1))))
|
||||
|
||||
(define string-alphabetic?
|
||||
(lambda (s1)
|
||||
(cerr 'string-alphabetic? (string? s1) "string" s1)
|
||||
(andmap char-alphabetic? (string->list s1))))
|
||||
|
||||
|
||||
(define string-whitespace?
|
||||
(lambda (s)
|
||||
(cerr 'string-upper-case? (string? s) "string" s)
|
||||
(andmap char-whitespace? (string->list s))))
|
||||
|
||||
(define string-upper-case?
|
||||
(lambda (s)
|
||||
(cerr 'string-upper-case? (string? s) "string" s)
|
||||
(andmap char-upper-case? (string->list s))))
|
||||
|
||||
|
||||
(define string-lower-case?
|
||||
(lambda (s)
|
||||
(cerr 'string-lower-case? (string? s) "string" s)
|
||||
(andmap char-lower-case? (string->list s))))
|
||||
|
||||
|
||||
;; ASL's member returns booleans.
|
||||
(define (-member x L)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
var isInexact = baselib.numbers.isInexact;
|
||||
var isComplex = baselib.numbers.isComplex;
|
||||
var isRational = baselib.numbers.isRational;
|
||||
|
||||
var isBytes = baselib.bytes.isBytes;
|
||||
|
||||
var isNatural = baselib.numbers.isNatural;
|
||||
var isPair = baselib.lists.isPair;
|
||||
|
|
@ -1180,6 +1180,13 @@
|
|||
|
||||
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'char->integer',
|
||||
1,
|
||||
function(M) {
|
||||
return checkChar(M, 'char->integer', 0).val.charCodeAt(0);
|
||||
});
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'integer->char',
|
||||
1,
|
||||
|
|
@ -1204,7 +1211,48 @@
|
|||
return baselib.chars.makeChar(ch.toLowerCase());
|
||||
});
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'char-numeric?',
|
||||
1,
|
||||
function(M) {
|
||||
var val = checkChar(M, 'char-numeric?', 0).val;
|
||||
return val >= '0' && val <= '9';
|
||||
});
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'char-alphabetic?',
|
||||
1,
|
||||
function(M) {
|
||||
var val = checkChar(M, 'char-alphabetic?', 0).val;
|
||||
return ((val >= 'a' && val <= 'z') ||
|
||||
(val >= 'A' && val <= 'Z'));
|
||||
});
|
||||
|
||||
var whitespaceRegexp = new RegExp("^\\s*$");
|
||||
installPrimitiveProcedure(
|
||||
'char-whitespace?',
|
||||
1,
|
||||
function(M) {
|
||||
var val = checkChar(M, 'char-whitespace?', 0).val;
|
||||
return val.match(whitespaceRegexp ? true : false);
|
||||
});
|
||||
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'char-upper-case?',
|
||||
1,
|
||||
function(M) {
|
||||
var val = checkChar(M, 'char-upper-case?', 0).val;
|
||||
return val === val.toUpperCase();
|
||||
});
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'char-lower-case?',
|
||||
1,
|
||||
function(M) {
|
||||
var val = checkChar(M, 'char-lower-case?', 0).val;
|
||||
return val === val.toLowerCase();
|
||||
});
|
||||
|
||||
|
||||
installPrimitiveProcedure(
|
||||
|
|
@ -1447,6 +1495,23 @@
|
|||
return isComplex(M.e[M.e.length - 1]);
|
||||
});
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'bytes?',
|
||||
1,
|
||||
function(M) {
|
||||
return isBytes(M.e[M.e.length-1]);
|
||||
});
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'byte?',
|
||||
1,
|
||||
function(M) {
|
||||
var v = M.e[M.e.length - 1];
|
||||
if(!isNatural(v)) { return false; }
|
||||
v = baselib.numbers.toFixnum(v);
|
||||
return v >= 0 && v < 256;
|
||||
});
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'rational?',
|
||||
1,
|
||||
|
|
@ -1678,6 +1743,13 @@
|
|||
return baselib.numbers.isInteger(M.e[M.e.length - 1]);
|
||||
});
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'exact-integer?',
|
||||
1,
|
||||
function (M) {
|
||||
return (baselib.numbers.isInteger(M.e[M.e.length - 1]) &&
|
||||
baselib.numbers.isExact(M.e[M.e.length - 1]));
|
||||
});
|
||||
|
||||
installPrimitiveProcedure(
|
||||
'exact-nonnegative-integer?',
|
||||
|
|
|
|||
|
|
@ -126,10 +126,12 @@
|
|||
prefix-in
|
||||
only-in
|
||||
rename-in
|
||||
except-in
|
||||
provide
|
||||
planet
|
||||
all-defined-out
|
||||
all-from-out
|
||||
prefix-out
|
||||
except-out
|
||||
rename-out
|
||||
struct-out
|
||||
|
|
@ -316,14 +318,14 @@ char?
|
|||
boolean?
|
||||
vector?
|
||||
struct?
|
||||
;; eof-object?
|
||||
;; bytes?
|
||||
;; byte?
|
||||
byte?
|
||||
number?
|
||||
complex?
|
||||
real?
|
||||
rational?
|
||||
integer?
|
||||
exact-integer?
|
||||
exact?
|
||||
exact-nonnegative-integer?
|
||||
inexact?
|
||||
|
|
@ -368,12 +370,7 @@ box?
|
|||
assq
|
||||
assv
|
||||
assoc
|
||||
;; remove
|
||||
;; filter
|
||||
;; foldl
|
||||
;; foldr
|
||||
;; sort
|
||||
;; build-list
|
||||
box
|
||||
;; box-immutable
|
||||
unbox
|
||||
|
|
@ -410,7 +407,6 @@ symbol->string
|
|||
format
|
||||
printf
|
||||
fprintf
|
||||
;; build-string
|
||||
;; string->immutable-string
|
||||
string-set!
|
||||
;; string-fill!
|
||||
|
|
@ -436,7 +432,6 @@ symbol->string
|
|||
vector-set!
|
||||
vector->list
|
||||
list->vector
|
||||
;; build-vector
|
||||
char=?
|
||||
char<?
|
||||
char>?
|
||||
|
|
@ -447,12 +442,12 @@ symbol->string
|
|||
char-ci>?
|
||||
char-ci<=?
|
||||
char-ci>=?
|
||||
;; char-alphabetic?
|
||||
;; char-numeric?
|
||||
;; char-whitespace?
|
||||
;; char-upper-case?
|
||||
;; char-lower-case?
|
||||
;; char->integer
|
||||
char-alphabetic?
|
||||
char-numeric?
|
||||
char-whitespace?
|
||||
char-upper-case?
|
||||
char-lower-case?
|
||||
char->integer
|
||||
integer->char
|
||||
char-upcase
|
||||
char-downcase
|
||||
|
|
|
|||
|
|
@ -34,8 +34,8 @@
|
|||
build-string
|
||||
build-list
|
||||
|
||||
#;compose
|
||||
#;compose1
|
||||
compose
|
||||
compose1
|
||||
)
|
||||
|
||||
(require (only-in "../unsafe/ops.rkt" unsafe-car unsafe-cdr))
|
||||
|
|
@ -313,14 +313,14 @@
|
|||
[else (cons (fcn j)
|
||||
(recr (add1 j) (sub1 i)))])))
|
||||
|
||||
#;(define-values [compose1 compose]
|
||||
(define-values [compose1 compose]
|
||||
(let ()
|
||||
(define-syntax-rule (app1 E1 E2) (E1 E2))
|
||||
(define-syntax-rule (app* E1 E2) (call-with-values (lambda () E2) E1))
|
||||
(define-syntax-rule (mk-simple-compose app f g)
|
||||
(let*-values
|
||||
([(arity) (procedure-arity g)]
|
||||
[(required-kwds allowed-kwds) (procedure-keywords g)]
|
||||
[(required-kwds allowed-kwds) (values '() '()) #; (procedure-keywords g)]
|
||||
[(composed)
|
||||
;; FIXME: would be nice to use `procedure-reduce-arity' and
|
||||
;; `procedure-reduce-keyword-arity' in the places marked below,
|
||||
|
|
@ -331,14 +331,14 @@
|
|||
[(x) (app f (g x))]
|
||||
[(x y) (app f (g x y))]
|
||||
[args (app f (apply g args))]))])
|
||||
(if (null? allowed-kwds)
|
||||
composed #;(if (null? allowed-kwds)
|
||||
composed
|
||||
(make-keyword-procedure ; <--- and here
|
||||
(lambda (kws kw-args . xs)
|
||||
(app f (keyword-apply g kws kw-args xs)))
|
||||
composed))))
|
||||
(define-syntax-rule (can-compose* name n g f fs)
|
||||
(unless (null? (let-values ([(req _) (procedure-keywords g)]) req))
|
||||
(unless (null? (let-values ([(req _) (values '() '()) #;(procedure-keywords g)]) req))
|
||||
(apply raise-type-error 'name "procedure (no required keywords)"
|
||||
n f fs)))
|
||||
(define-syntax-rule (can-compose1 name n g f fs)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user