├── (build my lisp) ├── .gitignore ├── builtin_func.c ├── builtin_func.h ├── core.mlisp ├── error_check.h ├── hello.ml ├── main.c ├── makefile ├── mpc.c ├── mpc.h ├── type.c └── type.h ├── .gitignore ├── HTDP ├── 11.1用函数生成列表.rkt ├── 11.2structure-in-list.rkt ├── 11.3-Lists-in-Lists-Files.rkt ├── 12.1The-list-Function.rkt ├── 12.3-Recursive-Auxiliary-Functions.rkt ├── 12.4.rkt ├── 13.1.rkt ├── 13.3.rkt ├── 13.6-FSM.rkt ├── 16.2.rkt ├── 16.4.rkt ├── 16.5.rkt ├── 17.1.rkt ├── 17.2.rkt ├── 17.3.rkt ├── 17.4.rkt ├── 18-using-abstractions.rkt ├── 18.7-练习和项目.rkt ├── 19-lambda.rkt ├── 19.2-computing-with-lambda.rkt ├── 19.3-Abstract-with-lambda.rkt ├── 19.4.rkt ├── 22.1-tree.rkt ├── 22.3-S-expressions.rkt ├── 22.6-Simplifying-Function.rkt ├── 23-Incremental-Refinement.rkt ├── 23.1-Date-Analysis.rkt ├── 23.2-Refining-Data-Definitions.rkt ├── 23.3-Refine-functions.rkt ├── 25-XML.rkt ├── 25.3-Domain-Specific-Languages.rkt ├── 25.4-Reading_XML.rkt ├── 26.6-Finger-Exercise-Two-Input.rkt ├── 26.同时处理.rkt ├── 29.1.rkt ├── 29.2.rkt ├── 30.1.rkt ├── 30.4.rkt ├── 31.1.rkt ├── 31.2.rkt ├── 32.2.rkt ├── 33.rkt ├── 36.rkt ├── 37.rkt ├── 38.2.rkt ├── 38.3.rkt ├── 38.rkt ├── CAR.rkt ├── Exercise-160- riot.rkt ├── Graphical-Editor.rkt ├── Russian-Dolls.rkt ├── Tax.rkt ├── binary-search-tree.rkt ├── cat2.rkt ├── chameleon.rkt ├── door.rkt ├── editor.rkt ├── happiness-gauge.rkt ├── happy-cat.rkt ├── in.txt ├── learnXML.rkt ├── list-excercise.rkt ├── list-world-shot.rkt ├── no-artical-ttt.dat ├── out.txt ├── output.xml ├── parse.rkt ├── posn类型练习.rkt ├── rocket-launch.rkt ├── scope-abstract.rkt ├── space-game.rkt ├── testxml.rkt ├── toBeContinue.rkt ├── trafic light.rkt ├── trafic light2.rkt ├── ttt.dat ├── ttt.txt ├── ufo-land.rkt ├── ufoMove.rkt ├── 间奏-数字的本质.rkt └── 间奏-计算的成本.rkt ├── LICENSE.md ├── Macros ├── FearOfMacros.rkt ├── FearOfMacros2.rkt └── fearOfMacros3.rkt ├── README.md ├── TSPL ├── 2.7-Assignment.rkt ├── 2.7-Assignment.ss ├── 3.1-语法扩展.rkt ├── 3.1-语法扩展.ss ├── 3.2-更多递归.rkt ├── 3.2-更多递归.ss ├── 3.3-continuations.rkt ├── 3.3-continuations.ss ├── 3.3.1.rkt ├── 3.3.2.rkt ├── 3.3.3.rkt ├── 3.3.5.ss ├── 3.4.1.rkt ├── 3.4.2.rkt ├── 3.4.3.rkt ├── 3.4.rkt ├── 3.5.1.rkt ├── 3.5.2.rkt ├── 3.5.3.ss ├── 3.5.4.ss ├── 3.5.rkt ├── 3.6.1.ss ├── 3.6.2.ss ├── 3.6.3.ss ├── 3.6.ss ├── 4.1.rkt ├── 4.2.rkt ├── 4.3.rkt ├── 4.4.rkt ├── 4.5.ss ├── 4.6.rkt ├── 4.7.rkt ├── 5.1.rkt ├── 5.2.ss ├── 5.3.rkt ├── 5.4.rkt ├── 5.5.rkt ├── 5.6.ss ├── 5.7.ss ├── 5.8.rkt ├── 5.9.rkt ├── 5.9.ss ├── 6.1.rkt ├── 6.2.rkt ├── 6.3.rkt ├── 6.4.rkt ├── test.rkt └── transhcan.rkt ├── bp ├── lose.rkt ├── main.rkt ├── operator.rkt ├── readme.md └── tensor.rkt ├── nothing ├── WebWiki.rkt ├── compile.rkt ├── lambda匿名递归.rkt ├── learn-vector.rkt ├── newtown.rkt ├── passwd ├── stream.rkt ├── λ匿名.rkt └── 简单的解释器.rkt ├── projectEuler ├── 1.cpp ├── 1.ss └── 2.ss ├── rackUnitExample ├── coverage │ ├── assets │ │ ├── app.js │ │ └── main.css │ ├── file.html │ └── index.html ├── file-test.rkt └── file.rkt ├── sicp ├── 1.1.sc ├── 1.10.sc ├── 1.11.sc ├── 1.12.sc ├── 1.13.sc ├── 1.14.dot ├── 1.14.png ├── 1.15.sc ├── 1.16.sc ├── 1.17.sc ├── 1.18.sc ├── 1.19.sc ├── 1.2.sc ├── 1.20.sc ├── 1.21.sc ├── 1.22.sc ├── 1.23.sc ├── 1.24.sc ├── 1.3.sc ├── 1.4.sc ├── 1.5.sc ├── 1.6.sc ├── 1.7.sc ├── 1.8.sc ├── 1.9.sc ├── sqrt.sc └── utils.sc └── web ├── .gitignore ├── index.html ├── lib ├── core │ ├── LICENSE │ ├── README.md │ ├── alist.sc │ ├── exception.sc │ ├── package.sc │ └── string.sc └── igropyr │ ├── LICENSE │ ├── README.md │ ├── http.sc │ ├── httpc.so │ ├── package.sc │ └── src │ ├── httpc.c │ ├── membuf.c │ └── membuf.h ├── main.ss └── package.sc /(build my lisp)/.gitignore: -------------------------------------------------------------------------------- 1 | main 2 | *.o 3 | .* -------------------------------------------------------------------------------- /(build my lisp)/builtin_func.h: -------------------------------------------------------------------------------- 1 | #include "error_check.h" 2 | #ifndef builtin_func_h 3 | #define builtin_func_h 4 | #include "type.h" 5 | 6 | extern mpc_parser_t *Lispy; 7 | 8 | // math 9 | lval *builtin_add(lenv *e, lval *a); 10 | lval *builtin_sub(lenv *e, lval *a); 11 | lval *builtin_mul(lenv *e, lval *a); 12 | lval *builtin_div(lenv *e, lval *a); 13 | lval *builtin_mod(lenv *e, lval *a); 14 | lval *builtin_is_zero(lenv *e,lval *a); 15 | lval *builtin_cmp(lenv *e,lval *a,char* op); 16 | lval *builtin_gt(lenv*e,lval*a); 17 | lval *builtin_ge(lenv*e,lval*a); 18 | lval *builtin_lt(lenv*e,lval*a); 19 | lval *builtin_le(lenv*e,lval*a); 20 | 21 | // bool 22 | lval *builtin_and(lenv *e, lval *a); 23 | lval *builtin_or(lenv *e, lval *a); 24 | lval *builtin_not(lenv *e, lval *a); 25 | lval *builtin_is_true(lenv *e, lval *a); 26 | 27 | // list oprator 28 | lval *builtin_list(lenv *e, lval *a); 29 | lval *builtin_car(lenv *e, lval *a); 30 | lval *builtin_head(lenv *e, lval *a); 31 | lval *builtin_join(lenv *e, lval *a); 32 | lval *builtin_cdr(lenv *e, lval *a); 33 | lval *builtin_quote(lenv *e,lval *a); 34 | 35 | // system 36 | lval *builtin_def(lenv *e, lval *a); 37 | lval *builtin_exit(lenv *e, lval *a); 38 | lval *builtin_eval(lenv *e, lval *a); 39 | lval *builtin_lambda(lenv *e, lval *a); 40 | lval *builtin_put(lenv *e, lval *a); 41 | lval *builtin_var(lenv *e, lval *a, char *func); 42 | lval *builtin_load(lenv *e,lval *a); 43 | lval *builtin_print(lenv *e,lval *a); 44 | lval *builtin_error(lenv *e,lval *a); 45 | lval *builtin_void(lenv *e,lval *a); 46 | 47 | lval *builtin_op(lenv *e, lval *a, char *op); 48 | 49 | // condition 50 | lval *builtin_if(lenv *e,lval *a); 51 | lval *builtin_equal(lenv *e,lval *a); 52 | 53 | //return what it get,get one return one 54 | lval *builtin_value(lenv *e,lval *a); 55 | 56 | #endif 57 | -------------------------------------------------------------------------------- /(build my lisp)/core.mlisp: -------------------------------------------------------------------------------- 1 | ;; 定义函数 2 | (def {fun} 3 | (lambda {args body} 4 | {def (head args) 5 | (lambda (cdr args) body)})) 6 | 7 | ;; 返回l的长度 8 | ;; l := Q-Expression 9 | ;; ==> number 10 | (fun {len l} 11 | {if (=? l {}) 12 | 0 13 | {+ 1 (len (cdr l))}}) 14 | 15 | 16 | ;; apply function f to q-expression 17 | ;; f := function 18 | ;; l := q-expression 19 | (fun {apply f l} 20 | {eval (join (list f) l)}) 21 | 22 | 23 | ;;map f to each element of l 24 | ;;f := function 25 | ;;l := qexpr 26 | (fun {map f l} 27 | {if (=? l {}) 28 | {value {}} 29 | {join (list (f (car l))) (map f (cdr l))}}) 30 | 31 | 32 | ;; reverse list l 33 | ;;==> list 34 | (fun {reverse l} 35 | {if (=? l {}) 36 | {value {}} 37 | {join (reverse (cdr l)) (head l) }}) 38 | 39 | ;; use function f as a filter 40 | ;;f := function 41 | ;;l := list 42 | ;;==> list 43 | (fun {filter f l} 44 | {if (=? l {}) 45 | {value {}} 46 | {if (f (car l)) 47 | {join (head l) (filter f (cdr l))} 48 | {filter f (cdr l)}}}) 49 | 50 | ;; 判断奇偶 51 | ;; x:= number 52 | ;; ==> bool 53 | (fun {odd? x} {=? 1 (% x 2)}) 54 | (fun {even? x} {not (odd? x)}) 55 | 56 | ;;判断列表是否为空 57 | ;;l := qexpr 58 | ;;==> bool 59 | (fun {empty? l} {=? l {}}) 60 | 61 | ;;将f z 依次应用于l 62 | ;;f := function 63 | ;;z := 幺元 64 | ;;l := list 65 | (fun {flodl f z l} 66 | {if (empty? l) 67 | z 68 | {flodl f (f z (car l)) (cdr l)}}) 69 | 70 | ;;绑定变量 71 | ;;bindings := qexpr 72 | ;;body := qexpr 73 | ;; 74 | ;;example 75 | ;;(let {{x 100} 76 | ;; {y 200}} 77 | ;; {+ x y}) 78 | ;;=====> 300 79 | (fun {let bindings body} 80 | {apply (lambda (map (lambda {x} {car x}) bindings) 81 | body) 82 | (map (lambda {x} {car (cdr x)}) bindings)}) 83 | 84 | 85 | (fun {first l} {car l}) 86 | (fun {second l} {car (cdr l)}) 87 | (fun {third l} {car (cdr (cdr l))}) 88 | 89 | (fun {case x & cs} 90 | {if (empty? cs) 91 | {error "no case found"} 92 | {if (=? x (first (first cs))) 93 | (second (first cs)) 94 | {apply case (join (list x) (cdr cs))}}}) 95 | 96 | (fun {select & cs} { 97 | if (== cs nil) 98 | {error "No Selection Found"} 99 | {if (fst (fst cs)) {snd (fst cs)} {unpack select (tail cs)}} 100 | }) 101 | 102 | (fun {fibnaci n} {if (=? n 0) 103 | 0 104 | {if (=? n 1) 105 | 1 106 | {+ (fibnaci (- n 1)) (fibnaci (- n 2))}} }) 107 | 108 | (case 9 109 | {1 (print "hello")} 110 | {2 (print "world")} 111 | {9 (print "nine")}) 112 | 113 | (if true {print "hello"} {print "no"}) 114 | 115 | -------------------------------------------------------------------------------- /(build my lisp)/error_check.h: -------------------------------------------------------------------------------- 1 | #ifndef error_check 2 | #define error_check 3 | 4 | /* 断言 */ 5 | #define LASSERT(args, cond, fmt, ...) \ 6 | if (!(cond)) { \ 7 | lval *err = lval_err(fmt, ##__VA_ARGS__); \ 8 | lval_del(args); \ 9 | return err; \ 10 | } 11 | 12 | /* 判断表达式的长度 */ 13 | #define LASSERT_NUM(func,args,num) \ 14 | LASSERT(args,args->count==num, \ 15 | "Function '%s' is passed incorrect number of argument. " \ 16 | "Expected %i , Got %i", \ 17 | func,num,args->count) 18 | 19 | /* 判断参数的类型 */ 20 | #define LASSERT_TYPE(func,args,position,t) \ 21 | LASSERT(args,(args->cell[position]->type)==t, \ 22 | "Function '%s' passed an incrorrect type of args at %i. " \ 23 | "Expected %s , Got %s", \ 24 | func,position,ltype_name(t),ltype_name(args->cell[position]->type)) 25 | 26 | #define LASSERT_NOT_EMPTY(func,args,index) \ 27 | LASSERT(args,args->cell[index]->count!=0, \ 28 | "Function '%s' passed {} for argument %i", \ 29 | func,index) 30 | 31 | #endif 32 | -------------------------------------------------------------------------------- /(build my lisp)/hello.ml: -------------------------------------------------------------------------------- 1 | (print "Hello World") 2 | -------------------------------------------------------------------------------- /(build my lisp)/makefile: -------------------------------------------------------------------------------- 1 | CC= gcc 2 | 3 | CFLAGS= -ledit -lm -g 4 | 5 | CSTD= -std=c99 6 | 7 | OBJ= main.o type.o builtin_func.o mpc.o 8 | 9 | EXE=main 10 | 11 | %.o: %.c 12 | $(CC) -o $@ -c $< $(CFLAGS) 13 | 14 | main: $(OBJ) 15 | $(CC) $(CSTD) $(OBJ) $(CFLAGS) -o $(EXE) 16 | 17 | clean: 18 | rm $(EXE) $(OBJ) 19 | 20 | debug: 21 | gdb -tui ./main.out 22 | -------------------------------------------------------------------------------- /(build my lisp)/type.h: -------------------------------------------------------------------------------- 1 | #include "builtin_func.h" 2 | 3 | #ifndef type_h 4 | #define type_h 5 | 6 | #include "mpc.h" 7 | /* 前置申明 */ 8 | 9 | enum { LVAL_VOID, LVAL_STR, LVAL_BOOL, LVAL_NUM, LVAL_ERR, LVAL_SYM, LVAL_SEXPR, LVAL_QEXPR, LVAL_FUN }; 10 | 11 | struct lval; // lisp 元素 12 | struct lenv; // lisp 环境 13 | 14 | typedef struct lval lval; 15 | typedef struct lenv lenv; 16 | typedef lval *(*lbuildin)(lenv *, lval *); //内建函数 17 | 18 | /* lisp value */ 19 | typedef struct lval { 20 | int type; 21 | 22 | // basic 23 | long num; 24 | char *err; 25 | char *sym; 26 | char *str; 27 | 28 | //function 29 | lbuildin builtin; 30 | lenv* env; 31 | lval* formals; 32 | lval* body; 33 | 34 | //expression s-expr or q-expr 35 | int count; 36 | struct lval **cell; 37 | } lval; 38 | 39 | struct lenv { 40 | lenv *par; //parent enviroment 41 | int count; 42 | char **syms; 43 | lval **vals; 44 | }; 45 | 46 | lenv *lenv_new(void); 47 | lenv *lenv_copy(lenv* e); 48 | lval *lenv_get(lenv *e, lval *k); 49 | void lenv_put(lenv *e, lval *k, lval *v); 50 | void lenv_def(lenv* e,lval *k,lval *v); 51 | 52 | lval *lval_quote(lval *v); 53 | void lval_del(lval *v); 54 | lval *lval_copy(lval *v); 55 | 56 | lval *lval_void(); 57 | lval *lval_bool(char *s); 58 | lval *lval_num(long x); 59 | lval *lval_sym(char *s); 60 | lval *lval_fun(lbuildin func); 61 | lval *lval_err(char *fmt, ...); 62 | lval *lval_sexpr(void); 63 | lval *lval_qexpr(void); 64 | lval *lval_lambda(lval *formals, lval *body); 65 | lval *lval_str(char *); 66 | 67 | lval *lval_add(lval *v, lval *x); 68 | lval *lval_copy(lval *v); 69 | lval *lval_pop(lval *v, int i); 70 | lval *lval_call(lenv *e,lval *f,lval* a); 71 | int lval_eq(lval*x ,lval* y); 72 | 73 | lval *lval_take(lval *v, int i); 74 | void lval_del(lval *v); 75 | char *ltype_name(int t); 76 | 77 | lval *lval_read_num(mpc_ast_t *t); 78 | lval *lval_read_str(mpc_ast_t *t); 79 | lval *lval_read(mpc_ast_t *t); 80 | 81 | void lval_print_str(lval* v); 82 | void lval_expr_print(lval *v, char open, char closen); 83 | void lval_print(lval *v); 84 | void lval_println(lval *v); 85 | 86 | lval eval(mpc_ast_t *t); 87 | lval eval_op(lval x, char *op, lval y); 88 | lval *lval_eval_sexpr(lenv *e, lval *v); 89 | lval *lval_eval(lenv *e, lval *v); 90 | 91 | #endif 92 | -------------------------------------------------------------------------------- /HTDP/11.1用函数生成列表.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname 11.1用函数生成列表) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp")) #f))) 4 | (define (wage h) 5 | (cond 6 | [(> h 100) (error "工作时间不得超过100小时")] 7 | [else (* 12 h)])) 8 | 9 | (define (wage* l) 10 | (cond 11 | [(empty? (rest l)) (cons (wage (first l)) '())] 12 | [(cons? l) (cons (wage (first l)) (wage* (rest l)))])) 13 | 14 | ;;华氏度转化为摄氏度 15 | (define (convertFC f) 16 | (* 5/9 (- f 32))) 17 | (define (convertFC* l) 18 | (cond 19 | [(empty? (rest l)) (cons (convertFC (first l)) '())] 20 | [(cons? l) (cons (convertFC (first l)) (convertFC* (rest l)))] 21 | [else (error "ERROR")])) 22 | 23 | ;;美元转化为欧元，2015/8/23 汇率0.8781 24 | (define (convert-euro US) 25 | (* US 0.8781)) 26 | (define (convert-euro* l) 27 | (cond 28 | [(empty? (rest l)) (cons (convert-euro (first l)) '())] 29 | [(cons? l) (cons (convert-euro (first l)) (convert-euro (rest l)))] 30 | [else (error "ERROR")])) 31 | 32 | ;;将一组字符串中的robot改为r2d2 33 | 34 | (define (subst-robot l) 35 | (cond 36 | [(empty? l) '()] 37 | [else (if 38 | (string=? "robot" (first l)) 39 | (cons "r2d2" (subst-robot (rest l))) 40 | (cons (first l) (subst-robot (rest l))))])) 41 | -------------------------------------------------------------------------------- /HTDP/11.2structure-in-list.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname 11.2structure-in-list) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp")) #f))) 4 | (define-struct work [employee rate hour]) 5 | (define-struct pay-check [name amount]) 6 | (define (wage.v2 w) 7 | (* (work-rate w) (work-hour w))) 8 | 9 | ;;list of work -> list of number 10 | (define (wage*.v2 low) 11 | (cond 12 | [(empty? low) '()] 13 | [else (cons 14 | (make-pay-check (work-employee (first low)) (wage.v2 (first low)) ) 15 | (wage*.v2 (rest low)))])) 16 | 17 | (wage*.v2 (cons (make-work "mike" 12.3 19) (cons (make-work "Tina" 100 100) '()))) 18 | ;;list of posn -> number 19 | ;;sum the posn-x 20 | (define (sum l) 21 | (cond 22 | [(empty? l) 0] 23 | [(cons? l) (+ (posn-x (first l)) (sum (rest l)))])) 24 | 25 | 26 | (check-expect (sum (cons (make-posn 1 2) (cons (make-posn 3 4) '()))) 4) 27 | ;;list of posn -> list of posn 28 | ;;(make-posn x y)-> (make-posn x (+ y 1)) 29 | (define (translate lop) 30 | (cond 31 | [(empty? lop) '()] 32 | [(cons? lop) (cons 33 | (make-posn (posn-x (first lop)) 34 | (+ 1 (posn-x (first lop)))) 35 | (translate (rest lop)))])) 36 | 37 | (define-struct phone [area switch four]) 38 | 39 | ;;a list of phone 40 | ;;replace area 713 with 281 41 | (define (foo p) 42 | (make-phone 43 | (if (= (phone-area p) 713 ) 281 (phone-area p)) 44 | (phone-switch p) 45 | (phone-four p))) 46 | (define (replace lop) 47 | (cond 48 | [(empty? lop) '()] 49 | [(cons? lop) (cons (foo (first lop)) 50 | (replace (rest lop)))])) 51 | 52 | -------------------------------------------------------------------------------- /HTDP/12.1The-list-Function.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname 12.1The-list-Function) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp")) #f))) 4 | ;exercise 181 5 | (check-expect (cons "a" (cons "b" (cons "c" (cons "d" (cons "e" '()))))) 6 | (list "a" "b" "c" "d" "e")) 7 | (check-expect (cons (cons 1 (cons 2 '())) '()) 8 | (list (list 1 2))) 9 | (check-expect (cons "a" (cons (cons 1 '()) (cons #false '()))) 10 | (list "a" (list 1) false)) 11 | (check-expect (cons (cons 1 (cons 2 '())) (cons (cons 2 '()) '())) 12 | (list (list 1 2) (list 2))) 13 | (check-expect (cons (cons "a" (cons 2 '())) (cons "hello" '())) 14 | (list (list "a" 2) "hello")) 15 | 16 | ;excercise 182 17 | (check-expect (list 0 1 2 3 4 5) 18 | (cons 0 (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 '()))))))) 19 | (check-expect (list (list "adam" 0) (list "eve" 1) (list "louisXIV" 2)) 20 | (cons (cons "adam" (cons 0 '())) (cons (cons "eve" (cons 1 '())) (cons (cons "louisXIV" (cons 2 '())) '())) )) 21 | (check-expect (list 1 (list 1 2) (list 1 2 3)) 22 | (cons 1 (cons (cons 1 (cons 2 '())) (cons (cons 1 (cons 2 (cons 3 '()))) '())))) 23 | 24 | ;excercise 183 25 | (check-expect (cons "a" (list 0 #false)) 26 | (cons "a" (cons 0 (cons false '())))) 27 | (check-expect (list (cons 1 (cons 13 '()))) 28 | (cons (cons 1 (cons 13 '())) '())) 29 | (check-expect (cons (list 1 (list 13 '())) '()) 30 | (cons (cons 1 (cons (cons 13 (cons '() '())) '())) '())) 31 | 32 | (check-expect (list '() '() (cons 1 '())) 33 | (cons '() 34 | (cons '() 35 | (cons (cons 1 '()) '())))) 36 | 37 | (check-expect (cons "a" (cons (list 1) (list #false '()))) 38 | (cons "a" 39 | (cons (cons 1 '()) (cons false (cons '() '()))))) -------------------------------------------------------------------------------- /HTDP/12.3-Recursive-Auxiliary-Functions.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname 12.3-Recursive-Auxiliary-Functions) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f () #f))) 4 | 5 | ;n ,list of number -> list of number 6 | ;将n插入到alon中,要求n>=它右边的数字 7 | (define (insert n alon) 8 | (cond 9 | [(empty? alon) (cons n alon)] 10 | [else (if (>= n (first alon)) 11 | (cons n alon ) 12 | (cons (first alon) (insert n (rest alon) )))])) 13 | 14 | 15 | ;list of number ->list of number 16 | ;对一列数字进行排序 17 | (define (sort> alon) 18 | (cond 19 | [(empty? alon) '()] 20 | [else (insert (first alon) (sort> (rest alon)))])) 21 | ;(sort> (list 9 9 9 9 9 9 9 9 )) 22 | 23 | ;;exercise 187 24 | ;a program that sort list of email message by date 25 | ;............................................ name 26 | 27 | (define-struct email [from date message]) 28 | ;;(make-email stirng number string) 29 | 30 | 31 | ;;insert email by date 32 | (define (insert-email e aloe) 33 | (cond 34 | [(empty? aloe)(cons e '())] 35 | [else (if (>= (email-date e) (email-date (first aloe))) 36 | (cons e aloe) 37 | (cons (first aloe) (insert-email e (rest aloe))))])) 38 | 39 | 40 | ;;aloe->a sorted list of email by date 41 | 42 | (define (sort-email aloe) 43 | (cond 44 | [(empty? aloe) '()] 45 | [else (insert-email (first aloe) (sort-email (rest aloe)))])) 46 | 47 | ;;insert email by name 48 | (define (insert-name e aloe) 49 | (cond 50 | [(empty? aloe) '()] 51 | [else (if (stringa list of player 68 | (define (insert-player p alop) 69 | (cond 70 | [(empty? alop) (cons p alop)] 71 | [else (if (>= (game-player-score p) (game-player-score (first alop))) 72 | (cons p alop) 73 | (cons (first alop) (insert-player p (rest alop))))])) 74 | 75 | (define (sort>player alop) 76 | (cond 77 | [(empty? alop) '()] 78 | [else (insert-player (first alop) (sort>player (rest alop)))])) 79 | 80 | 81 | 82 | ;;exercise 189 83 | ;search-sorted ,quickly find a number in a sorted list of number 84 | 85 | ;number,alon->T/F 86 | ;判断一个数字是否存在在一个从大到小的链表里 87 | (define (search-sorted n alon) 88 | (cond 89 | [(empty? alon) false] 90 | [(= n (first alon)) true] 91 | [(> n (first alon)) false] 92 | [(< n (first alon)) (search-sorted n (rest alon))])) 93 | ;(search-sorted 3 (list 9 9 2 1)) 94 | 95 | ;exercise 190 96 | ;得到一个列表所有的前缀子列表 97 | ; 98 | (define (prefix l) 99 | (cond 100 | [(empty? l) '()] 101 | [else (cons l (prefix (reverse (rest (reverse l)))))])) 102 | 103 | 104 | ;;suffix 105 | ;后缀子列表 106 | (define (suffix l) 107 | (cond 108 | [(empty? l) '()] 109 | [else (cons l (suffix (rest l)))])) 110 | (prefix (list 1 2 3 4 5 6)) 111 | ;(suffix (list 1 2 3 4 5 6)) 112 | ;2015-08-30 17:20:34 113 | -------------------------------------------------------------------------------- /HTDP/12.4.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname |12.4|) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp")) #f))) 4 | (define MT (empty-scene 50 50)) 5 | 6 | ;polygon->image 7 | ;将一个多边形变成一个图形 8 | (define (lineRender im p q) 9 | (scene+line im 10 | (posn-x p) (posn-y p) (posn-x q) (posn-y q) "red")) 11 | ;;找到poly的最后一个节点 12 | (define (findLast p) 13 | (cond 14 | [(empty? (rest p)) (first p)] 15 | [else (findLast (rest p))])) 16 | ;;pre 是从第一个到最后一个的图像 17 | ;pre的基础上加上最后到第一个的线 18 | (define (last2first p pre) 19 | (lineRender pre (first p) (findLast p))) 20 | ;;从第一个画到最后一个点 21 | (define (first2last p) 22 | (cond 23 | [(empty? (rest p)) MT] 24 | [else (lineRender (first2last (rest p)) (first p) (first (rest p)))])) 25 | 26 | (define (poly-render p) 27 | (cond 28 | [(< (length p) 3) (error "至少要有三个点") ] 29 | [else (last2first p (first2last p))]) ) 30 | (define (X a) (poly-render (list (make-posn 0 0) (make-posn 50 0) (make-posn 25 25 )(make-posn 50 50) (make-posn 0 50) (make-posn 25 25) )) ) 31 | (big-bang 0 32 | [to-draw X]) 33 | -------------------------------------------------------------------------------- /HTDP/13.1.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname |13.1|) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t write repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp")) #f))) 4 | (define DictionaryLocation "/usr/share/dict/words") 5 | (define DictionaryAsList (read-lines DictionaryLocation)) 6 | 7 | ;;String->list of String 8 | ;找到给定单词的所有可能字母组合 9 | 10 | (check-member-of (alternativeWords "cat") 11 | (list "act" "cat") 12 | (list "cat" "act")) 13 | 14 | (define (allWordsFromRat? w) 15 | (and (member? "rat" w) 16 | (member? "art" w) 17 | (member? "tar" w))) 18 | 19 | (check-satisfied (alternativeWords "rat") allWordsFromRat?) 20 | 21 | 22 | 23 | 24 | ;list of words->list of strings 25 | (define (words->strings low) 26 | (cond 27 | [(empty? low) '()] 28 | [else (cons (word->string (first low)) (words->strings (rest low)))])) 29 | 30 | ;stirng->word 31 | ;字符到一个个字母组成的列表 32 | (define (string->word s) 33 | (cond 34 | [(= 0 (string-length s)) (error "字符串长度为0")] 35 | [(= 1 (string-length s)) (cons s '())] 36 | [else (cons (substring s 0 1) 37 | (string->word (substring s 1 (string-length s))))])) 38 | 39 | 40 | ;word->string 41 | (define (word->string w) 42 | (cond 43 | [(empty? w) ""] 44 | [else (string-append (first w) (word->string (rest w)))])) 45 | 46 | ;;list of strings->list of strings 47 | ;找出所有出现在字典里面的字符 48 | (define (in-dictionary los) 49 | (cond 50 | [(empty? los) '()] 51 | [else (if (member? (first los) DictionaryAsList ) 52 | (cons (first los) (in-dictionary (rest los))) 53 | (in-dictionary (rest los)))])) 54 | 55 | ;word->list of string 56 | ;找到一个单词所有可能的组合 57 | (define (arrangements word) 58 | (cond 59 | [(empty? word) '()] 60 | [else (insert2words (first word) (arrangements (rest word)))])) 61 | 62 | 63 | ;1string ,list of words ->list of words 64 | ;将一个字母插入到 a list of word 65 | ;这里前面((两个判断中第一个是判断low是否进入函数时就为空 66 | ;第二个判断条件在递归时会触发 67 | ;这样写可以区分递归时碰到empty元素时是递归一开始list就为空还是到达递归结束时才碰到的empty元素 68 | (define (insert2words c low) 69 | (cond 70 | [(empty? low) (heart '() '() c)] 71 | [(empty? (rest low)) (heart '() (first low) c)] 72 | [else (append (heart '() (first low) c ) (insert2words c (rest low)))])) 73 | 74 | ;;这个程序的核心 75 | ;pre 必须为'() post可以是word 76 | ;c 为要插入的字母 77 | ;输出是将c 插入到post的所有位置 ->a list of words 78 | (define (heart pre post c) 79 | (cond 80 | [(empty? post) (list (append pre (list c)))] 81 | [else (cons 82 | (append (append pre (list c)) post) 83 | (heart (append pre (list (first post))) (rest post) c))])) 84 | ;;去除列表中因为word中存在重复字母而造成的重复单词 85 | (define (removeRepeat los) 86 | (cond 87 | [(empty? los) '()] 88 | [(= 1 (length los) ) los] 89 | [else(if (member? (first los) (rest los)) 90 | (removeRepeat (rest los)) 91 | (cons (first los) (removeRepeat (rest los)))) ])) 92 | (define (alternativeWords s) 93 | (removeRepeat (in-dictionary (words->strings (arrangements (string->word s))))) ) 94 | (alternativeWords "hash") 95 | -------------------------------------------------------------------------------- /HTDP/13.6-FSM.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname 13.6-FSM) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t write repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp")) #f))) 4 | 5 | (define-struct transition [current next]) 6 | 7 | (define fsm-traffic 8 | (list (make-transition "red" "green") 9 | (make-transition "green" "yellow") 10 | (make-transition "yellow" "red"))) 11 | 12 | (define (state=? s1 s2) 13 | (if (and (string=? (transition-current s1) (transition-current s2)) 14 | (string=? (transition-next s1) (transition-next s2))) 15 | true false)) 16 | 17 | (define BW-fsm 18 | (list (make-transition "black" "white") 19 | (make-transition "white" "black"))) 20 | 21 | (define (simulate a-fsm current) 22 | (big-bang (make-fs a-fsm current) 23 | [to-draw state-render] 24 | [on-key find-next-state])) 25 | (define-struct fs [fsm current]) 26 | (define (state-render fs) 27 | (square 100 "solid" (fs-current fs))) 28 | (define (find-next-state fs key) 29 | (make-fs (fs-fsm fs) (find (fs-fsm fs) (fs-current fs)))) 30 | 31 | (define (find fsm c) 32 | (cond 33 | [(empty? fsm) (error "未找到下一状态")] 34 | [else (if (string=? c (transition-current (first fsm))) 35 | (transition-next(first fsm)) 36 | (find (rest fsm) c))])) 37 | ;(simulate fsm-traffic "red") 38 | (define-struct ktransition [current key next]) 39 | (define key-fsm 40 | (list 41 | (make-ktransition "a" "a" "a") 42 | (make-ktransition "a" "b" "b") 43 | (make-ktransition "b" "b" "b") 44 | (make-ktransition "b" "c" "c") 45 | (make-ktransition "c" "b" "b") 46 | (make-ktransition "c" "c" "c") 47 | (make-ktransition "c" "d" "d") 48 | (make-ktransition "b" "d" "d") 49 | (make-ktransition "d" "any" "end") 50 | (make-ktransition "end" "any" "end") 51 | )) 52 | 53 | (define (simulate.key a-fsm current) 54 | (big-bang (make-fs a-fsm current) 55 | [to-draw key-state-render] 56 | [on-key find-next-key])) 57 | 58 | (define (key-state-render fs) 59 | (text (fs-current fs) 24 "black")) 60 | 61 | (define (find-next-key fs key) 62 | (make-fs (fs-fsm fs) (find-key (fs-fsm fs) (fs-current fs) key))) 63 | (define (find-key fsm c ke) 64 | (cond 65 | [(empty? fsm) "error"] 66 | [else (if (and 67 | (if (string=? c (ktransition-current (first fsm))) true 68 | (if (string=? "any" (ktransition-current (first fsm) )) true false)) 69 | (if (string=? ke (ktransition-key (first fsm) )) true 70 | (if (string=? "any" (ktransition-key (first fsm))) true false))) 71 | (ktransition-next (first fsm)) (find-key (rest fsm) c ke))])) 72 | (simulate.key key-fsm "a") 73 | -------------------------------------------------------------------------------- /HTDP/16.2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (define (squared>? x c) 3 | (> (* x x) c)) 4 | (squared>? 3 10) 5 | (squared>? 4 10) 6 | (squared>? 5 10) 7 | 8 | 9 | ;;not empty list of number ->the biggest smallest or the most ... one 10 | (define (most operator l) 11 | (cond 12 | [(empty? l) (error "列表为空无法判断") ] 13 | [(empty? (rest l)) (first l)] 14 | [else (cond 15 | [(operator (first l) (most operator (rest l))) (first l)] 16 | [else (most operator (rest l))])])) 17 | 18 | (define (most.v2 R l) 19 | (cond 20 | [(empty? (rest l)) (first l)] 21 | [else (R (first l) (most.v2 R (rest l)))])) 22 | (most.v2 max (list 1 21 2 3 23 2)) 23 | (most < (list 1 2 3 4 5 6 7 8 9 -1 5 19 -100)) 24 | (most.v2 max (list 1 12 12 34 43 45 456 56 56 56 565 6 5 65 6 5 6 56 5 6 2 23 43 45 5 6 6 7 7 7 7 6 6 6 4 4 4 4 4 32 2 2 2 2 2 22 222 ) ) 25 | -------------------------------------------------------------------------------- /HTDP/16.4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;(define (f x) x) 3 | 4 | ;(cons f '()) 5 | ;(f f) 6 | ;(cons f (cons 10 (cons (f 10) '()))) 7 | 8 | 9 | 10 | ;(define (f x) (x 10)) 11 | ;(define (f x) (x f)) 12 | (define (f x y) (x 'a y 'b)) 13 | 14 | 15 | 16 | ;Exercise 232 17 | (define (function=at-1.2-3-and-5.775? f1 f2) 18 | (and 19 | (= (f1 1.2) (f2 1.2)) 20 | (= (f1 3) (f2 3)) 21 | (= (f1 -5.775) (f2 -5.775)))) 22 | 23 | -------------------------------------------------------------------------------- /HTDP/16.5.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname |16.5|) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp")) #f))) 4 | (define (extract R l n) 5 | (cond 6 | [(empty? l) '()] 7 | [else (if (R (first l) n) 8 | (cons (first l) (extract R (rest l) n)) 9 | (extract R (rest l) n))])) 10 | (define (square>? a b) 11 | (> (* a a ) b)) 12 | ;(extract < (list 1 2 3 4 5) 7) 13 | (extract square>? (list 3 4 5 7 8) 10) 14 | ;(extract < (cons 6 (cons 4 '())) 5) 15 | ;(extract < (cons 4 '() ) 5) 16 | -------------------------------------------------------------------------------- /HTDP/17.1.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname |17.1|) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp")) #f))) 4 | ;Exercise 238 5 | ;list of number[number->number]->list of number 6 | (define (tabulate n f) 7 | (cond 8 | [(= n 0) (list (f 0))] 9 | [else 10 | (cons (f n) 11 | (tabulate (sub1 n) f))])) 12 | ;(tabulate 9 tan) 13 | 14 | 15 | ;Exercise 239 16 | ;list of X ,(X,Y->Y) ,Y ->Y 17 | (define (fold2 l f last-case) 18 | (cond 19 | [(empty? l) last-case] 20 | [else (f (first l) (fold2 (rest l)))])) 21 | 22 | ;;Posn,img ->img 23 | (define (place-dot p img) 24 | (place-image dot (posn-x p) (posn-y p) img)) 25 | ;;图形常量 26 | (define emt (empty-scene 100 100)) 27 | (define dot (circle 3 "solid" "red")) 28 | 29 | (define (product_From_Abstract l) 30 | (fold2 l * 1)) 31 | 32 | (define (image*_from_abstract l) 33 | (fold2 l place-dot emt)) 34 | -------------------------------------------------------------------------------- /HTDP/17.2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | 4 | ;;一个函数的注释是重用的关键 5 | ;所以你在描述一个函数时要概括出共性,以保证通用性 6 | ;list of X -> list of X 7 | ;list of Number-> list of Number 8 | ;list of X -> list of Y 9 | ;list of IR->list of String 10 | ;Exercise 241 11 | ;[Number->Boolean] 12 | (define (f1 n) 13 | (odd? n)) 14 | ;[Boolean String ->String] 15 | (define (f2 b s) 16 | (if b s "I have eat it hahahha ^-^? ")) 17 | ;[Number,Number,Number->Number] 18 | (define (f3 n1 n2 n3) 19 | (+ n1 n2 n3)) 20 | ;[Number ->list of Number] 21 | (define (f4 n) 22 | (cond 23 | [(zero? n) '()] 24 | [else (cons n (f4 (sub1 n)))])) 25 | ;[list of Number ->Boolean] 26 | (define (f5 l ) 27 | (cond 28 | [(empty? (rest l)) true] 29 | [else (and (< (first l) (first (rest l))) (f5 (rest l)))])) 30 | ;Exercise 242 31 | ;[list of Number ,[Number,Number->boolean] ->list of Number] 32 | ;[list of string ,[String,String-> Boolean]->list of String] 33 | ;[lsit of X ,[X ,X -> Boolean] -> list of X] 34 | ;[lsit of IR,[IR,IR->boolean]->llst of IR] 35 | 36 | 37 | ;Exercise 243 38 | ;[list of Number [Number-> Number]->list of Number] 39 | ;[list of sting [string ->string]->list of string] 40 | ;[list of X [X->X] ->list of X] 41 | -------------------------------------------------------------------------------- /HTDP/17.3.rkt: -------------------------------------------------------------------------------- 1 | ;;single point of contral 2 | ;控制单点?不晓得是什么意思 3 | ;似乎是说抽象函数有助于化简程序,让你的程序更加易读,易于理解. 4 | ;就可以用一个函数控制一些普通函数(好直白的翻译) 5 | ;有了错误只要改一个函数就可以修复错误,算法改进也可以只改一个函数 6 | ;以点带面,似乎这种形容更加恰当. 7 | ;好像基于类的面向对象的语言也是这种编程思想的继承 8 | ;又一小节结束了.有点快 9 | -------------------------------------------------------------------------------- /HTDP/17.4.rkt: -------------------------------------------------------------------------------- 1 | ;abstractions from templates 2 | ;从模板抽象 3 | ;以前一直从一般函数->抽象函数 4 | ;这一章直接从函数模板得到抽象函数 5 | ;有很厉害吗? 6 | ;尽管这个话题还在研究中,我们现在只是了解一下基本的idea 7 | #lang racket 8 | 9 | (define (fun_for_l l) 10 | (cond 11 | [(empty? l) ...] 12 | [else (... (first l) ... (fun_for_l (rest l)))])) 13 | ;;这是一般的列表处理函数模板,确实这种形式出现了很多次 14 | ; 15 | ; 16 | ; 17 | ;抽象之后就是以下的函数 18 | (define (reduce l base combine) 19 | (cond 20 | [(empty? l) base] 21 | [else (combine (first l) (reduce (rest l base combine)))])) 22 | ;之后就可以用一行定义出sum ,product(将列表里面的数字全部×qilai) 23 | 24 | 25 | 26 | 27 | ;[list of sum] -> number 28 | (define (sum l) 29 | (reduce l 0 +)) 30 | 31 | ;[list of number ]->number 32 | (define (product l) 33 | (reduce l 1 *)) 34 | 35 | ;(reduce 运算对象(列表) 幺元 运算符) 36 | -------------------------------------------------------------------------------- /HTDP/19-lambda.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;第十九章 lambda,匿名函数,构建一些小函数. 3 | ;可以用来不过来化简程序 4 | ;一门语言,希望可以在表达上给予程序员最大的表达能力,最简洁的表达方式.这在语言的设计上是一种艺术 5 | 6 | (lambda (x) (* 10 x)) 7 | (lambda (name) (string-append "Hello ," name ",How are you?")) 8 | ((lambda (x) (* 10 x)) 2) 9 | ((lambda (name rst) (string-append name "," rst) ) "沈" "小双") 10 | (map (lambda (x) (* x 10)) (list 1 2 3 4)) 11 | ( (lambda () 10) ) 12 | ( (lambda x 10) 2 ) 13 | ( (lambda (x y) (x y y)) list 8) 14 | ((lambda (x y) 15 | (+ x (* x y))) 16 | 1 2) 17 | ((lambda (x y) 18 | (+ x 19 | (local ((define z (* y y))) 20 | (+ (* 3 z) 21 | (/ 1 x))))) 22 | 1 2) 23 | ;Exercise 267 24 | ;1 25 | (lambda x (< x 10)) 26 | ;2 27 | ( (lambda (x y) (number->string (* x y))) 1 2) 28 | ;3 29 | ( (lambda (x) (if (odd? x) 1 0)) 5 ) 30 | 31 | 32 | -------------------------------------------------------------------------------- /HTDP/19.2-computing-with-lambda.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define (f x) (* 10 x)) 4 | ;is short for 5 | 6 | #| (define f |# 7 | #| (lambda (x) |# 8 | #| (* 10 x))) |# 9 | 10 | #| ;;exercise 268 |# 11 | #| ;number->boolean |# 12 | #| (define (compare x) |# 13 | #| (= (f-plain x) (f-lambda x))) |# 14 | 15 | 16 | 17 | ;;这中间有许多单步测试的练习,就不在vim里面测试了 18 | 19 | ;这里有一个比较好玩的语句 20 | ;注意没有在vim中实测运行过,racket的结果就是死循环这条语句没有结束的时候 21 | ;((lambda (x) ( x x ) ) (lambda (x) (x x)) 22 | ;这条语句会不停的展开一致保持这个状态,现在是这样,以后也一直会使这样 23 | 24 | 25 | ;;GG 26 | ;2015-09-26 15:10:50 27 | -------------------------------------------------------------------------------- /HTDP/19.3-Abstract-with-lambda.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | 4 | (define-struct posn [x y]) 5 | 6 | ;Exercise 272 7 | (define hui-lv 1.2) 8 | 9 | 10 | (define (court0-euro l) 11 | (map (lambda (x) (* x hui-lv) l))) 12 | 13 | (define (translate l) 14 | (map (lambda (p) (list (posn-x p) (posn-y p))) l)) 15 | 16 | 17 | ;Exercise 273 18 | (define-struct ir [name price]) 19 | (define ( sort_by_price l) 20 | (sort l (lambda (i1 i2) (> (ir-price i1 ) (ir-price i2))))) 21 | 22 | 23 | ;Exercise 274 24 | ;Number ,ua ,list of ir ->list of ir 25 | (define (eliminate-exp n ua l) 26 | (filter (lambda (ir) (< (ir-price ir) ua)) l)) 27 | 28 | (define (recall ty l) 29 | (filter (lambda (ir) (not (string=? (ir-name ir) ty))) l)) 30 | 31 | (define (selection l1 l2) 32 | (local( 33 | (define (in? n l) 34 | (cond 35 | [(empty? l) false] 36 | [(= n (first l) ) true] 37 | [else (in? n (rest l))])) 38 | (define (in-l1? n) 39 | (in? n l2)) 40 | ) 41 | (filter in-l1? l2))) 42 | 43 | ;不知道怎么用lambda实现,因为lambda为匿名调用所以在做递归的时候总是不知道怎么实现 44 | 45 | 46 | ;;Exercise 275 47 | 48 | 49 | (define (build-nature n) 50 | (build-list n (lambda (n) n))) 51 | ;(build-nature 7) 52 | (define (build-nature+1 n) 53 | (build-list n (lambda (n) (+ n 1)))) 54 | 55 | (define f (λ (x) (* x x)) ) 56 | (f 3) 57 | 58 | ;;由于λ演算的递归实现还没有想到所以先跳过这些东西 59 | -------------------------------------------------------------------------------- /HTDP/19.4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;[list of Number] [Number Number ->Boolean]->[list of Number] 4 | ;sort the Number accroading to the cmp of tow Number 5 | (define (sort-cmp alon0 cmp) 6 | (local( 7 | ;[list of number]->[list of Number] 8 | (define (isort alist ) 9 | (cond 10 | [(empty? alist ) '()] 11 | [else (insert (first alist) (isort (rest alist)))])) 12 | ;将n插入到已经排好序的alon中去 13 | (define (insert n alon) 14 | (cond 15 | [(empty? alon ) (cons n '())] 16 | [(cmp n (first alon)) (cons n alon)] 17 | [else (cons (first alon) (insert n (rest alon)) )])) 18 | ) 19 | (isort alon0))) 20 | 21 | 22 | (sort-cmp (list 1 2 3 5 2 3 1) <) 23 | -------------------------------------------------------------------------------- /HTDP/22.1-tree.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;(make-child Child Child String Number String) 4 | ; 出生年份 眼睛颜色 5 | (define-struct child [father mother name date eye]) 6 | 7 | (define-struct no_parent []) 8 | (define MTFT (make-no_parent )) 9 | ; Oldest Generation: 10 | (define Carl (make-child MTFT MTFT "Carl" 1926 "green")) 11 | (define Bettina (make-child MTFT MTFT "Bettina" 1926 "green")) 12 | 13 | ; Middle Generation: 14 | (define Adam (make-child Carl Bettina "Adam" 1950 "hazel")) 15 | (define Dave (make-child Carl Bettina "Dave" 1955 "black")) 16 | (define Eva (make-child Carl Bettina "Eva" 1965 "blue")) 17 | (define Fred (make-child MTFT MTFT "Fred" 1966 "pink")) 18 | 19 | ; Youngest Generation: 20 | (define Gustav (make-child Fred Eva "Gustav" 1988 "brown")) 21 | 22 | ;;Exercise 296 23 | ;count-person 24 | ;child->Number 25 | ;计算一个家族(一颗家族树)的人数 26 | (define (count_person a_ftree) 27 | (cond 28 | [(no_parent? a_ftree ) 0] 29 | [else (+ 1 30 | (count_person (child-father a_ftree )) 31 | (count_person (child-mother a_ftree)))])) 32 | ;(count_person Gustav) 33 | ;(count_person Dave) 34 | 35 | 36 | ;;Exercise 297 37 | ;计算一个家族树的平均年龄 38 | ; 39 | 40 | ;年龄总数 41 | ;Child->Number 42 | (define (sum_age a_ftree) 43 | (cond 44 | [(no_parent? a_ftree ) 0] 45 | [else (+ (- 2015 (child-date a_ftree)) 46 | (sum_age (child-father a_ftree)) 47 | (sum_age (child-mother a_ftree)))])) 48 | 49 | ; 50 | ;Child->Number 51 | ;平均年龄 52 | (define (average_age a_ftree) 53 | (/ 54 | (sum_age a_ftree) 55 | (count_person a_ftree))) 56 | 57 | ;;Exercise 298 58 | ;得到一颗家族树的所有 59 | 60 | (define (eye-color a_ftree) 61 | (cond 62 | [(no_parent? a_ftree) '()] 63 | [else (append (list (child-eye a_ftree)) (eye-color (child-father a_ftree) ) (eye-color (child-mother a_ftree)) )])) 64 | 65 | #| (eye-color Gustav ) |# 66 | #| (eye-color Adam) |# 67 | 68 | 69 | ;;Exercise 299 70 | ;child->Boolean 71 | ;判断一个child是否有一个拥有一个蓝色眼睛的祖先 72 | ;a_ftree == a family tree 73 | (define (blue_eyed_child? a_ftree) 74 | (cond 75 | [(no_parent? a_ftree) false] 76 | [(string=? "blue" (child-eye a_ftree)) true] 77 | [else (or (blue_eyed_child? (child-father a_ftree)) 78 | (blue_eyed_child? (child-mother a_ftree)))])) 79 | 80 | (define (blue_eyed_ancestor a_ftree) 81 | (or (blue_eyed_child? (child-mother a_ftree) ) 82 | (blue_eyed_child? (child-father a_ftree)))) 83 | 84 | ;(blue_eyed_ancestor Adam) 85 | 86 | -------------------------------------------------------------------------------- /HTDP/22.6-Simplifying-Function.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname 22.6-Simplifying-Function) (read-case-sensitive #t) (teachpacks ((lib "abstraction.rkt" "teachpack" "2htdp") (lib "image.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "abstraction.rkt" "teachpack" "2htdp") (lib "image.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp")) #f))) 4 | 5 | ; S-expr Symbol Atom -> S-expr 6 | ; replaces all occurrences of old in sexp with new 7 | 8 | (check-expect (substitute 'world 'hello 0) 'world) 9 | (check-expect (substitute '(world hello) 'hello 'bye) '(world bye)) 10 | (check-expect (substitute '(((world) bye) bye) 'bye '42) '(((world) 42) 42)) 11 | 12 | (define (atom? x) 13 | (cond 14 | [(symbol? x) true] 15 | [(string? x) true] 16 | [(number? x) true] 17 | [else false])) 18 | 19 | (define (substitute sexp old new) 20 | (local (; S-expr -> S-expr 21 | (define (subst-sexp sexp) 22 | (cond 23 | [(atom? sexp) (subst-atom sexp)] 24 | [else (subst-sl sexp)])) 25 | 26 | ;anyc->boolean 27 | ;judge wheatheaer somec is a atom 28 | (define (atom? x) 29 | (cond 30 | [(string? x) true] 31 | [(number? x) true] 32 | [(symbol? x) true] 33 | [else false])) 34 | ; SL -> S-expr 35 | (define (subst-sl sl) 36 | (cond 37 | [(empty? sl) '()] 38 | [else (cons (subst-sexp (first sl)) (subst-sl (rest sl)))])) 39 | 40 | ; Atom -> S-expr 41 | (define (subst-atom at) 42 | (cond 43 | [(number? at) at] 44 | [(string? at) at] 45 | [(symbol? at) (if (symbol=? at old) new at)]))) 46 | ; — IN — 47 | (subst-sexp sexp))) 48 | 49 | 50 | (define (substitute.v2 sexp old new) 51 | (local (; S-expr -> S-expr 52 | (define (subst-sexp sexp) 53 | (cond 54 | [(atom? sexp) (subst-atom sexp)] 55 | [else (subst-sl sexp)])) 56 | 57 | ; SL -> S-expr 58 | (define (subst-sl sl) 59 | (map subst-sexp sl)) 60 | 61 | ; Atom -> S-expr 62 | (define (subst-atom at) 63 | (if (eq? at old) new at))) 64 | ; — IN — 65 | (subst-sexp sexp))) 66 | 67 | (define (substitute.v3 sexp old new) 68 | (local(;S-expr->S-expr 69 | (define (subst-sexp sexp) 70 | (cond 71 | [(atom? sexp) (if (eq? sexp old) new sexp )] 72 | [else (map subst-sexp sexp)])) 73 | 74 | ;SL -> S-expr 75 | (define (subst-sl sexp) 76 | (map subst-sl sexp)) 77 | ) 78 | ;-- IN-- 79 | (subst-sexp sexp) 80 | )) 81 | 82 | ;;最终化简的结果 83 | 84 | (define (Substitute sexp old new) 85 | (cond 86 | [(atom? sexp) (if (eq? sexp old) new old)] 87 | [else (map ( λ (s) (Substitute s old new)) sexp) ])) 88 | -------------------------------------------------------------------------------- /HTDP/23-Incremental-Refinement.rkt: -------------------------------------------------------------------------------- 1 | ;并不知道什么意思,从字面上看就是增量优化 2 | ;似乎是在说迭代优化 3 | ;构建模型 4 | ;程序员像物理学家那样,逐步构建出准确的模型. 5 | ;关键是要找到准确的数据来代表真实世界的信息,比且运用合适的函数来处理这些信息 6 | ;有些时候程序员必须重新定义模型,因为用户的需求变了 7 | ;这个过程从基础的信息开始,然后逐渐加入需要的其他特殊可能 8 | ;之前其实也有迭代的思想体现,但是可能没有那么明显,在这一章中我们将这一方法深化为程序开发的一条准则 9 | ;这章的例子是电脑的文件系统 10 | -------------------------------------------------------------------------------- /HTDP/23.1-Date-Analysis.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;我们的电脑把程序和数据存放在文件里面 4 | ;一个文件是一些符号的一个序列 5 | ;这里我们把文件视作一个字符串 6 | ;而文件有放在一些文件夹里面 7 | ;一个文件夹里面通常会包含一些文件,或者文件夹里面还有文件夹 8 | ;我们把它称作子文件夹,子文件夹里面还可以包含子文件夹. 9 | ;所有的这些文件夹,子文件夹.从整体上看,我们称作文件树 10 | 11 | -------------------------------------------------------------------------------- /HTDP/23.2-Refining-Data-Definitions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;Exercise 315 3 | ;列出一些用户经常会问的关于文件夹的问题 4 | ;文件名是什么? 5 | ;这个文件夹有多大? 6 | ;这个文件夹在哪里? 7 | ;文件夹里面有有什么? 8 | ;文件夹的所有者是谁? 9 | 10 | 11 | ;Model1 12 | ;; A Dir.v1 (short for directory) is one of: 13 | ; – '() 14 | ; – (cons File.v1 Dir.v1) 15 | ; – (cons Dir.v1 Dir.v1) 16 | ; A File.v1 is a Symbol. 17 | 18 | ;Exercise 316 19 | ;(cons 'file (cons 'file2 '() ))))) 20 | 21 | 22 | ;Exercise 317 23 | 24 | (define (how-many dir) 25 | (cond 26 | [(empty? dir) 0] 27 | [(symbol? dir) 1] 28 | [else (+ (how-many (first dir)) (how-many (rest dir)))])) 29 | 30 | ;(how-many (cons 'flie1 (cons 'file2 (cons 'file3 '())))) 31 | 32 | 33 | ;现在我们就要细化我们的模型啦 34 | ;Molde2 35 | 36 | (define-struct dir [name content]) 37 | 38 | ;所以我们的模型就便成 39 | ;; A Dir.v2 is a structure: 40 | ; (make-dir Symbol LOFD) 41 | 42 | ; A LOFD (short for list of files and directories) is one of: 43 | ; – '() 44 | ; – (cons File.v2 LOFD) 45 | ; – (cons Dir.v2 LOFD) 46 | 47 | ; A File.v2 is a Symbol. 48 | 49 | ;Exercise 318 50 | ;model2 设计数据例子 51 | (define dir-tree.v2 52 | (make-dir 'd (list 'file1 'file2 (make-dir 'dir2-name (list 'file3)) 'filename ))) 53 | 54 | (define (how-many.v2 d) 55 | (local( 56 | (define (count-content c) 57 | (cond 58 | [(empty? c) 0] 59 | [(symbol? c) 1] 60 | [(dir? c ) (how-many.v2 c)] 61 | [else (+ (count-content (first c)) (count-content (rest c)))])) 62 | ) 63 | (count-content (dir-content d)))) 64 | 65 | ;(how-many.v2 dir-tree.v2) 66 | 67 | 68 | ;model 3 69 | ;模型3,现在我们把file也作为一种struct 因为file本身也会有许多不同的属性,仅仅将其作为一种symbol处理未免丧失了太多的信息. 70 | 71 | (define-struct file [name size content]) 72 | ;File.v3 (make-file symbol number string) 73 | 74 | ;Here is the refined data definition: 75 | ; A Dir.v3 is a structure: 76 | ; (make-dir.v3 Symbol Dir* File*) 77 | 78 | ; A Dir* is one of: 79 | ; – '() 80 | ; – (cons Dir.v3 Dir*) 81 | 82 | ; A File* is one of: 83 | ; – '() 84 | ; – (cons File.v3 File*) 85 | 86 | (define tree3 (make-dir 'dirname (list (make-file 'filename 4 "") (make-file 'file2name 7 "") (make-dir 'dir2name (list (make-file 'file3name 6 ""))) (make-file 'file4name 1 "") )) ) 87 | 88 | (define (how-many.v3 d) 89 | (local( 90 | (define (count-content c) 91 | (cond 92 | [(empty? c) 0] 93 | [(file? c) 1] 94 | [(dir? c) (how-many.v3 c)] 95 | [else (+ (count-content (first c) ) (count-content(rest c)))]))) 96 | (count-content (dir-content d)))) 97 | 98 | (how-many.v3 tree3) 99 | 100 | ;Exercise 323 101 | ; 102 | ;Dir.v3 is one of 103 | ;--(make-dir symbol '()) 104 | ;--(make-dir symbol LOFD) 105 | ;;LOFD is list of file and dir 106 | 107 | ;使用foldr 化简函数 108 | 109 | (define (how-many.v4 d) 110 | (local( 111 | 112 | ;file/dir/'() number ->number 113 | (define (f c n) 114 | (cond 115 | [(file? c) (+ 1 n)] 116 | [(dir? c) (+ n (how-many.v4 c))] 117 | [(empty? c) n])) 118 | ) 119 | (foldr f 0 (dir-content d)))) 120 | (how-many.v4 tree3) 121 | -------------------------------------------------------------------------------- /HTDP/23.3-Refine-functions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require htdp/dir) 3 | (define d0 (create-dir "/home/richard/.ssh")) 4 | 5 | (define (how-many d) 6 | (local( 7 | 8 | ;file/dir/'() number ->number 9 | (define (f1 c n) 10 | (cond 11 | [(file? c) (+ 1 n)] 12 | [(dir? c) (+ n (how-many c))] 13 | [(empty? c) n])) 14 | (define (f2 c n) 15 | (cond 16 | [(dir? c) (+ n (how-many c))] 17 | [(empty? c) n])) 18 | (define files-number 19 | (foldr f1 0 (dir-files d))) 20 | (define dirs-file-number 21 | (foldr f2 0 (dir-dirs d))) 22 | ) 23 | (+ files-number dirs-file-number))) 24 | 25 | (how-many d0) 26 | 27 | 28 | (define (find? d target-name) 29 | (local( 30 | (define (find-in-files target-name files) 31 | (cond 32 | [(empty? files) false] 33 | [(file? files) (if (symbol=? target-name (file-name files)) true false)] 34 | [else (or (find-in-files target-name (first files)) 35 | (find-in-files target-name (rest files)))])) 36 | (define (find-in-dirs target-name dirs) 37 | (cond 38 | [(empty? dirs) false] 39 | [else (or (find-in-files target-name (dir-files (first dirs) )) 40 | ( 41 | find-in-dirs target-name (rest dirs)))])) 42 | 43 | ) 44 | (or (find-in-files target-name (dir-files d)) 45 | (find-in-dirs target-name (dir-dirs d))))) 46 | 47 | ;(find? d0 'fucq.py) 48 | 49 | ;ls 50 | ;列出当前文件夹下的文件夹以及文件; 51 | ;dir->string 52 | 53 | (define (ls d) 54 | (local( 55 | ;list of dirs->list of symbol 56 | (define (ls-dir d) 57 | (cond 58 | [(empty? d) '()] 59 | [else (cons (dir-name (first d)) (ls-dir (rest d)))])) 60 | ;list of files->list of symbol 61 | (define (ls-files f) 62 | (cond 63 | [(empty? f) '()] 64 | [else (cons (file-name (first f)) (ls-files (rest f)))])) 65 | ) 66 | (append (ls-dir (dir-dirs d)) (ls-files (dir-files d))))) 67 | 68 | 69 | (ls d0) 70 | 71 | 72 | ;du 73 | ;dir->Number 74 | ;计算出整个文件树下面的文件的总共大小 75 | ;一个文件夹的大小记为1 76 | (define (du d) 77 | (local( 78 | ;计算文件的大小 79 | (define (du-dirs d) 80 | (cond 81 | [(empty? d) 0] 82 | [else (+ 1 (du (first d)) (du-dirs (rest d))) ])) 83 | (define (du-files f) 84 | (cond 85 | [(empty? f) 0] 86 | [else (+ (file-size (first f)) (du-files (rest f)) )])) 87 | ;计算文件夹的大小 88 | ) 89 | (+ 1 (du-dirs (dir-dirs d)) (du-files (dir-files d))))) 90 | (du d0) 91 | -------------------------------------------------------------------------------- /HTDP/29.1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require 4 | lang/htdp-advanced) 5 | 6 | (define (bundle s n) 7 | (cond 8 | [(not (and (cons? s) (number? n))) (error "参数不符合要求")] 9 | [(= 0 n) (error "n不可以为0")] 10 | [(empty? s) '()] 11 | [else (cons (implode (take s n)) (bundle (drop s n) n))])) 12 | 13 | ; [List-of X] N -> [List-of X] 14 | ; retrieves the first n items in l if possible or everything 15 | 16 | ; [List-of X] N -> [List-of X] 17 | ; remove the first n items from l if possible or everything 18 | 19 | ;; (bundle '("a" "b" "c" "d") 2) 20 | ;Exercise 396 21 | ;NO 参数不符合要求 22 | 23 | ;Exercise 397 24 | 25 | ;[list of emlement] Number {list of emlement ->chunks}===>list of chunks 26 | (define (list->chunks s n f) 27 | (cond 28 | [(empty? s) '()] 29 | [else (cons (f (take s n)) (list->chunks (drop s n) n f))])) 30 | 31 | (define (bundle.v2 s n) 32 | (list->chunks s n implode)) 33 | 34 | ;Exercise 398 35 | (define (my_partition s n) 36 | (local((define l (string-length s))) 37 | (cond 38 | [(= n 0) (error "n不可以是0")] 39 | [(< n l) 40 | (cons (substring s 0 n ) (my_partition (substring s n l ) n) ) ] 41 | [else (cons s'())] 42 | ))) 43 | 44 | (my_partition "" 100) 45 | -------------------------------------------------------------------------------- /HTDP/29.2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define (smaller-items alon threshold) 4 | (cond 5 | [(empty? alon) '()] 6 | [else (if (<= (first alon) threshold) 7 | (cons (first alon) (smaller-items (rest alon) threshold)) 8 | (smaller-items (rest alon) threshold))])) 9 | 10 | 11 | (define (quick-sort alon f) 12 | (local ( 13 | (define (judge f l n) 14 | (filter (λ (x) (if (f x n) #t #f)) l))) 15 | ;;;----IN---- 16 | (cond 17 | [(empty? alon) '()] 18 | [(= 1 (length alon)) alon] 19 | [(< (length alon) 10) (sort alon <)] 20 | [else (append 21 | (quick-sort (judge f (rest alon) (first alon)) f ) 22 | ;;以下部分为练习410所用到 23 | ;;会造成(quick-sort)的第二个参数无效,造成结果无序 24 | ;; (quick-sort (smaller-items (rest alon) (first alon)) f) 25 | (list (first alon)) 26 | (quick-sort (judge (λ (a b) (not (f a b)) ) (rest alon) (first alon)) f))]))) 27 | 28 | (define (random-list n M) 29 | (cond 30 | [(= n 0) '()] 31 | [else (cons (random M) (random-list (sub1 n) M))])) 32 | 33 | (quick-sort (random-list 100 10000) <=) 34 | -------------------------------------------------------------------------------- /HTDP/30.1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; 这一小节介绍了如何用一般的思路来设计算法 3 | 4 | ;; 1,对于一个问题的描述,首先我们要确定合理的数据结构(呈现数据的方式) 5 | ;; 2,写下大致的函数的头,申明他们的功能,并且是如何得到结果的 6 | ;; 3,理一个程序使如何计算的是非常重要的,他可以让你更加深入的理解你的代码,也可以让未来的代码的阅读者们更加容易理解这份代码 7 | ;; 4,对于一个通用的算法来说,我们的设计分为两部分"trivially solvable"以及其他的部分 8 | ;; 对于此,我的理解如下,一个通用算法通常要考虑所面对的情况,有些是琐碎和边界情况,或者叫做特殊情况 9 | ;; 另外一些是通常情况.对于特使的条件特殊处理,一般情况一般处理然后把所有的通用情况合并起来就得到了所有通常情况的合解 10 | 11 | 12 | ;; 基于以上的认识,所有的算法都可以大致的如下处理 13 | 14 | ;; (define (通用问题求解函数 问题) 15 | ;; (cond 16 | ;; [(特殊问题吗? 问题) (特殊求解 问题)] 17 | ;; [else 18 | ;; (合并解 19 | ;; ....问题.... 20 | ;; (通用问题求解函数 (问题的第一方面 问题)) 21 | ;; ..... 22 | ;; (通用问题求解函数 (问题的第N方面 问题)))])) 23 | -------------------------------------------------------------------------------- /HTDP/30.4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;Exercise 413 4 | ;相当于从最大的数字开始一个一个向下找 5 | ;(min n m) 因为m n的最大公约数必然比最小的小或等于最小的 6 | 7 | (define (gdc.v1 m n) 8 | (local( 9 | (define (gdc x) 10 | (cond 11 | [(= x 1) 1] 12 | [else (if (= (remainder m x) (remainder n x) 0) 13 | x 14 | (gdc (sub1 x)))]))) 15 | (gdc (min m n)))) 16 | ;; (gdc.v1 101135853 45014640) 17 | ;实现的方式很烂,但是不至于让电脑运算好几秒 18 | 19 | (define (gdc m n) 20 | (local( 21 | (define (clever-gdc large small) 22 | (cond 23 | [(= 0 small) large] 24 | [else (clever-gdc small (remainder large small))]))) 25 | (clever-gdc (max m n) (min m n)))) 26 | ;; (gdc 101135853 45014640) 27 | 28 | (define (gdc.v3 m n) 29 | (local ( 30 | (define (member? n l) 31 | (cond 32 | [(empty? l) #f] 33 | [(= n (first l)) #t] 34 | [else (member? n (rest l))])) 35 | (define (divisors n biggest) 36 | (cond 37 | [(= 1 biggest) (cons 1 '())] 38 | [(= 0 (remainder n biggest)) (cons biggest (divisors n (sub1 biggest)))] 39 | [else (divisors n (sub1 biggest))])) 40 | (define (largest-commom l1 l2) 41 | (cond 42 | [(member? (first l1) l2) (first l1)] 43 | [else (largest-commom (rest l1) l2)])) 44 | (define (gdc small large) 45 | (largest-commom (divisors small small) (divisors large small)))) 46 | (gdc (min m n) (max m n )))) 47 | (gdc 101135853 45014640) 48 | -------------------------------------------------------------------------------- /HTDP/31.1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require 2htdp/image 3 | 2htdp/universe) 4 | ;分形几何 5 | 6 | (define SMALL 4) 7 | 8 | (define small-triangle (triangle SMALL 'outline 'red)) 9 | 10 | (define (sierpinski side) 11 | (cond 12 | [(<= side SMALL) (triangle side 'outline 'red)] 13 | [else (local ((define half-sized (sierpinski (/ side 2)))) 14 | (above half-sized 15 | (beside half-sized half-sized)))])) 16 | 17 | (big-bang 500 18 | [to-draw sierpinski] 19 | [name "谢尔斯宾三角"]) 20 | -------------------------------------------------------------------------------- /HTDP/31.2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ; [Number -> Number] Number Number -> Number 3 | ; determines R such that f has a root in [R,(+ R TOLERANCE)] 4 | ; assume f is continuous 5 | ; assume (or (<= (f left) 0 (f right)) (<= (f right) 0 (f left))) 6 | ; generative divide interval in half, the root is in one of the two 7 | ; halves, pick according to assumption 8 | 9 | (define TOLERANCE 0.5) 10 | 11 | (define (find-root f left right) 12 | (cond 13 | [(<= (- right left) TOLERANCE) left] 14 | [else 15 | (local ((define mid (/ (+ left right) 2)) 16 | (define f@mid (f mid)) 17 | (define f@left (f left)) 18 | (define f@right (f right))) 19 | (cond 20 | [(or (<= f@left 0 f@mid) (<= f@mid 0 f@left)) 21 | (find-root f left mid)] 22 | [(or (<= f@mid 0 f@right) (<= f@right 0 f@mid)) 23 | (find-root f mid right)] 24 | [else (error "something wrong") ]))])) 25 | 26 | (define (ploy x) 27 | (* (- x 5) ( - x -1))) 28 | 29 | ;; (find-root ploy -1 14) 30 | 31 | ;Exercise 428 32 | 33 | ;The function consumes a number n and a list of n2 numbers. 34 | ;It produces a list of n lists of n numbers 35 | 36 | (define (creat-matrix n l) 37 | (local( 38 | ;;从list l里面拿出n个元素 39 | (define (take-from l n) 40 | (cond 41 | [(= 0 n) '()] 42 | [else (cons (first l) (take-from (rest l) (sub1 n)))])) 43 | (define (drop-from l n) 44 | (cond 45 | [(= 0 n) l] 46 | [else (drop-from (rest l) (sub1 n))]))) 47 | (cond 48 | [(>= (length l) n) (cons (take-from l n) (creat-matrix n (drop-from l n)))] 49 | [else '()]))) 50 | 51 | (creat-matrix 3 '(1 2 3 4 5 6 7 8 9)) 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | -------------------------------------------------------------------------------- /HTDP/32.2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;Exercise 432 4 | 5 | ;f a function [Number-->Number] 6 | ;a b, left and right side of the area 7 | (define (intrgrate-kepler f a b) 8 | (local ( 9 | (define mid (/ (+ a b) 2))) 10 | (+ (/ (* (- mid a) (+ (f a) (f mid))) 2) 11 | (/ (* (- b mid) (+ (f mid) (f b)))) 2))) 12 | 13 | (define (f x) 14 | (* 3 x x)) 15 | 16 | ;; (intrgrate-kepler f 0 10) 17 | 18 | (define (integrate-rectangles f a b) 19 | (local( 20 | (define R 1000) 21 | (define W (/ (- b a) R)) 22 | (define S (/ W 2)) 23 | ;;计算长方形的面积 24 | (define (Area-rec w h) (* w h)) 25 | (define (cal-height n) 26 | (f (+ a S (* n W)))) 27 | (define (Area n) 28 | (cond 29 | [(< n R) (+ (Area-rec W (cal-height n)) (Area (+ n 1)))] 30 | [else 0]))) 31 | (Area 0))) 32 | 33 | ;; (integrate-rectangles f 0 10) 34 | 35 | (define (integrate-dc f a b) 36 | (local( 37 | (define A 0.001) 38 | (define W (- b a)) 39 | (define mid (/ (+ a b) 2))) 40 | (cond 41 | [(> W A) (+ (integrate-dc f a mid) (integrate-dc f mid b))] 42 | [else (* W (f mid))]))) 43 | (integrate-dc f 0 10) 44 | -------------------------------------------------------------------------------- /HTDP/38.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname |38|) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "abstraction.rkt" "teachpack" "2htdp")) #f))) 4 | 5 | ;; (λ (x) x) 6 | ;; ;需要y被绑定 7 | ;; ;; (λ (x) y) 8 | ;; (λ (y) (λ (x) y)) 9 | ;; ((λ (x) x) (λ (x) x)) 10 | ;; ;无限循环 11 | ;; ;((λ (x) (x x)) (λ (x) (x x))) 12 | ;; (((λ (y) (λ (x) y)) 13 | ;; (λ (z) z)) 14 | ;; (λ (w) w)) 15 | ;; ;;==> 16 | ;; ((λ (x) (λ (z) z)) 17 | ;; (λ (w) w)) 18 | ;; ;;==> 19 | ;; ((λ (z) z) (λ (w) w)) 20 | ;; ;;==> 21 | ;; (λ (w) w) 22 | 23 | (define ex1 '(λ (x) x)) 24 | (define ex2 '(λ (x) y)) 25 | (define ex3 '(λ (y) (λ (x) y))) 26 | (define ex4 '((λ (x) (x x)) (λ (x) (x x)))) 27 | 28 | ;Exercise 488 29 | (define (is-var? item) 30 | (if (and (symbol? item) (not (symbol=? 'λ item))) 31 | #t #f)) 32 | 33 | (define (is-λ? item) 34 | (if (cons? item) 35 | (if (symbol? (first item)) 36 | (if (symbol=? 'λ (first item)) 37 | #t #f) 38 | #f) 39 | #f)) 40 | 41 | (define (is-app? item) 42 | (if (and (cons? item) (= 2 (length item))) 43 | #t #f)) 44 | 45 | (define (λ-para item) 46 | (cond 47 | [(= 2 (length item)) (second (first item))] 48 | [(= 3 (length item)) (second item)])) 49 | (define (λ-body item) 50 | (cond 51 | [(= 2 (length item)) (third (first item))] 52 | [(= 3 (length item)) (third item)])) 53 | (define (app-fun item) 54 | (first item)) 55 | (define (app-arg item) 56 | (second item)) 57 | 58 | ;;给出λ表达式的参数 59 | ;; (define (declareds) 60 | ;; ) 61 | 62 | (define (undeclareds le0) 63 | (local (; Lam [List-of Symbol] -> [List-of Symbol] 64 | ; accumulator declareds is a list of all λ 65 | ; parameters on the path from le0 to le 66 | (define (undeclareds/a le declareds) 67 | (cond 68 | [(is-var? le) 69 | (if (member? le declareds) le '*undeclared)] 70 | [(is-λ? le) 71 | (local ((define para (λ-para le)) 72 | (define newd (append para declareds)) 73 | (define body (undeclareds/a (λ-body le) newd))) 74 | (list 'λ para body))] 75 | [(is-app? le) 76 | (list (undeclareds/a (app-fun le) declareds) 77 | (undeclareds/a (app-arg le) declareds))] 78 | [else (cons le declareds)]))) 79 | (undeclareds/a le0 '()))) 80 | (is-λ? ex4) 81 | (check-expect (undeclareds ex1) ex1) 82 | (check-expect (undeclareds ex2) '(λ (x) *undeclared)) 83 | (check-expect (undeclareds ex3) ex3) 84 | (check-expect (undeclareds ex4) ex4) 85 | -------------------------------------------------------------------------------- /HTDP/CAR.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname CAR) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp"))))) 4 | (define WIDTH-OF-WORLD 400) 5 | (define WHEEL-RADIUS 5) 6 | (define WHEEL-DISTANCE (* WHEEL-RADIUS 3)) 7 | (define WHEEL (circle WHEEL-RADIUS 'solid 'black)) 8 | (define SPACE (rectangle WHEEL-DISTANCE WHEEL-RADIUS 'solid 'white)) 9 | (define BOTH-WHEEL (beside WHEEL SPACE WHEEL)) 10 | (define CAR-BODY1 (rectangle (* WHEEL-RADIUS 5) WHEEL-RADIUS 'solid 'red)) 11 | (define CAR-BODY2 (rectangle (* WHEEL-RADIUS 9) (* WHEEL-RADIUS 2) 'solid 'red)) 12 | (define CAR-BODY (above CAR-BODY1 CAR-BODY2)) 13 | (define CAR (underlay/xy CAR-BODY WHEEL-RADIUS (* 2 WHEEL-RADIUS) BOTH-WHEEL)) 14 | (define tree 15 | (underlay/xy (circle 10 'solid 'green) 16 | 9 15 17 | (rectangle 2 20 'solid 'brown))) 18 | ; WorldState Number Number String -> WorldState 19 | ; places the car at the x coordinate if me is "button-down" 20 | (define (hyper x-position-of-car x-mouse y-mouse me) 21 | (cond 22 | [(string=? "button-down" me) x-mouse] 23 | [else x-position-of-car])) 24 | (define BACKGROUND (empty-scene WIDTH-OF-WORLD (* 10 WHEEL-RADIUS))) 25 | (define (render x) (underlay/xy BACKGROUND x (+ (* WHEEL-RADIUS (sin x)) (* 3 WHEEL-RADIUS)) CAR)) 26 | (define (tock ws) 27 | (+ ws 3)) 28 | (define (smaller? ws) (>= ws WIDTH-OF-WORLD)) 29 | (define (main ws) 30 | (big-bang ws 31 | [on-tick tock] 32 | [to-draw render] 33 | [stop-when smaller?] 34 | [on-mouse hyper])) 35 | 36 | (main 0) 37 | -------------------------------------------------------------------------------- /HTDP/Exercise-160- riot.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname |Exercise-160- riot|) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp")) #f))) 4 | (define (col n img) 5 | (cond 6 | [(zero? (sub1 n)) img] 7 | [(positive? (sub1 n)) (above img (col (sub1 n) img ))])) 8 | 9 | (define (row n img) 10 | (cond 11 | [(zero? (sub1 n)) img] 12 | [(positive? (sub1 n)) (beside img (row (sub1 n) img ))])) 13 | 14 | (define Background (row 18 (col 18 (empty-scene 10 10)))) 15 | 16 | (define Ball (circle 5 "solid" "red")) 17 | 18 | (define (play l) 19 | (cond 20 | [(empty? l) Background ] 21 | [else (place-image Ball (posn-x (first l)) (posn-y (first l)) (play (rest l)))])) 22 | 23 | (define (drawer pair) 24 | (cond 25 | [(empty? pair) (play pair)] 26 | [else (play (pair-l pair))])) 27 | 28 | 29 | ;;设定n为小球的数量，l为列表 30 | (define-struct pair [n l]) 31 | 32 | 33 | (define (time-hander p) 34 | (make-pair 35 | (sub1 (pair-n p)) 36 | (cons 37 | (make-posn (* 10 (random 18)) (* 10 (random 18))) 38 | (pair-l p) ))) 39 | 40 | (define (stop-judge p) 41 | (if (= 0 (pair-n p)) true false)) 42 | 43 | (define (main pair) 44 | (big-bang pair 45 | [to-draw drawer ] 46 | [on-tick time-hander 1] 47 | [stop-when stop-judge])) 48 | 49 | (main (make-pair 6 '())) -------------------------------------------------------------------------------- /HTDP/Tax.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname Tax) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t write repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp"))))) 4 | (define (Tax x) 5 | (cond 6 | [(< 0 x 1000) 0] 7 | [(<= 1000 x 10000)(* (- x 1000) 0.05)] 8 | [else (+ (* 0.05 9000) (* 0.08 (- x 10000)))])) 9 | 10 | -------------------------------------------------------------------------------- /HTDP/binary-search-tree.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;空节点 3 | (define-struct no-info []) 4 | 5 | (define NONE (make-no-info)) 6 | 7 | (define-struct node [ssn name left right]) 8 | ;;一个二元树节点,ssn 和 name 都是节点值,所存放的内容ssn name 9 | ;left and right 是node类型或者NONE 10 | 11 | 12 | ;;n->name/false 13 | ;n代表ssn,如果树中存在社保号为n的人则输出n对应的名字,若没有则输出false 14 | 15 | (define (JF&N a b ) 16 | (cond 17 | [(and (boolean? a) (boolean? b)) false] 18 | [else (if (symbol? a) a b)])) 19 | 20 | (define (search_bt n BT) 21 | (cond 22 | [(no-info? BT) false] 23 | [(= n (node-ssn BT)) (node-name BT)] 24 | [else (JF&N (search_bt n (node-left BT)) (search_bt n (node-right BT)))])) 25 | 26 | ;测试用树 27 | (define a-bt (make-node 3 'lj (make-node 1 'fy NONE (make-node 2 'sxs NONE NONE)) NONE)) 28 | 29 | ;(search_bt 2828 a-bt ) 30 | 31 | ;BT->list of number 32 | ;将一棵树中所有的元素的ssn转化为数字的链表 33 | (define (inorder BT) 34 | (cond 35 | [(no-info? BT) '()] 36 | [else (append (inorder (node-left BT)) 37 | (list (node-ssn BT) ) 38 | (inorder (node-right BT)))])) 39 | ;(inorder a-bt) 40 | 41 | ;;二元搜索树的要求,升序或者降序 依次为 left BT right 42 | ;不妨设是从左向右 43 | 44 | ;社工号,二元搜索树 -> 社工号对应的名字或者NONE 表示没有找到 45 | 46 | (define (search_bst n bst) 47 | (cond 48 | [(no-info? bst) NONE] 49 | [(= n (node-ssn bst)) (node-name bst)] 50 | [else (if (> n (node-ssn bst)) 51 | (search_bst n (node-right bst)) 52 | (search_bst n (node-left bst)))])) 53 | 54 | ;(search_bst 1 a-bt) 55 | 56 | 57 | ;Exercise 312 58 | ; 59 | ;构造二元搜索树 60 | ; 61 | ;It consumes a BST B, a number N, and a symbol S 62 | (define (creat_bst B N S) 63 | (cond 64 | [(no-info? B) (make-node N S NONE NONE)] 65 | [else (if (> N (node-ssn B)) 66 | (make-node (node-ssn B) (node-name B) (node-left B) (creat_bst (node-right B) N S)) 67 | (make-node (node-ssn B) (node-name B) (creat_bst (node-left B) N S) (node-right B)))])) 68 | 69 | 70 | ;从一个list 创造一个二元搜索树 71 | ;list of node->BST 72 | 73 | (define (creat_bst_from_list l) 74 | (cond 75 | [(empty? l) NONE] 76 | [else (creat_bst (creat_bst_from_list (rest l)) (first (first l)) (second (first l)) )])) 77 | 78 | (define sample 79 | '((99 o) 80 | (77 l) 81 | (24 i) 82 | (10 h) 83 | (95 g) 84 | (15 d) 85 | (89 c) 86 | (29 b) 87 | (63 a))) 88 | ;(creat_bst_from_list sample) 89 | (search_bst 8 (creat_bst_from_list sample)) 90 | 91 | -------------------------------------------------------------------------------- /HTDP/happiness-gauge.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname happiness-gauge) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp"))))) 4 | ;;最小0，，最大100 5 | ;;时间触发函输每秒减少0.1 6 | ;;number->number 7 | ;;give 100 expect 99.5 8 | ;;give 0.01 expect 0 9 | (define (decrease-0.5 x)(if (>= x 0.1) (- x 0.1) 0 )) 10 | ;; 11 | (define (increase-1/5 x) (if (<= (+ x (* x 1/5)) 100) (+ x (* x 1/5)) 100)) 12 | ;; 13 | (define (jump-1/3 x) (if (> (- x (* x 1/3)) 0 ) (- x (* x 1/3)) 0) ) 14 | 15 | ;;number->string 16 | ;;give 50 expect "开心指数：50" 17 | (define (happy x) (string-append "开心:" (number->string x) )) 18 | (define (scene x)( 19 | cond 20 | [(= x 100) (rectangle 300 61.8 'solid 'red)] 21 | [(= x 0) (rectangle 300 61.8 'outline 'black)] 22 | [else (overlay (rectangle 300 61.8 'outline 'black) (rectangle 300 61.8 'solid 'red) )])) 23 | 24 | (define (display x) (overlay (text (happy x) 24 'indigo) (scene x))) 25 | (define (key-event x a-key) (cond 26 | [(key=? a-key "up" ) (increase-1/5 x)] 27 | [(key=? a-key "down" ) (jump-1/3 x)] 28 | [else x])) 29 | (define (main x) 30 | (big-bang x 31 | [to-draw display] 32 | [on-tick decrease-0.5 1] 33 | [on-key key-event])) 34 | 35 | (main 100) -------------------------------------------------------------------------------- /HTDP/in.txt: -------------------------------------------------------------------------------- 1 | Exercise 485. Design the function split. Use the accumulator design recipe to improve on the result of exercise 484. After all, the hints already point out that when the function discovers the correct split point, it needs both parts of the list and one part is obviously lost due to recursion. image 2 | 3 | Once you have solved this exercise, equip the main function of A Graphical Editor, Revisited with a clause for mouse clicks. As you experiment with moving the cursor via mouse clicks, you will notice that it does not exactly behave like applications that you use on your other devices—even though split passes all its tests. 4 | 5 | Graphical programs, like editors, call for experimentation to come up with best “look and feel” experiences. In this case, your editor is too simplistic with its placement of the cursor. After the applications on your computer determine the split point, they also determine which letter division is closer to the x-coordinate and place the cursor there. 6 | -------------------------------------------------------------------------------- /HTDP/learnXML.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | ;#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname learnXML) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t quasiquote repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp")) #f))) 4 | #lang racket 5 | (require 2htdp/image) 6 | (require test-engine/racket-tests) 7 | (define SIZE 12) 8 | (define COLOR 'black) 9 | (define BULLET 10 | (beside (circle 1 'solid 'black) (text " " SIZE COLOR))) 11 | 12 | ; Image -> Image 13 | ; marks item with bullet 14 | (define (bulletize item) 15 | (beside/align 'center BULLET item)) 16 | 17 | 18 | ;判读list中是否为参数 19 | (define (list_of_attributes? x) 20 | (or (empty? x) (cons? (first x)))) 21 | 22 | ;x->T/F是否是一个word 23 | (define (word? x) 24 | (and (symbol=? 'word (first x)) 25 | (symbol=? 'text (first (first (second x)))) 26 | (string? (second (first (second x)))))) 27 | 28 | (define (word-text x) 29 | (if (word? x) 30 | (second (first (second x))) 31 | (error "这不是一个xword"))) 32 | 33 | (define (xexpr-content xe) 34 | (local ((define optional-loa+content (rest xe))) 35 | (cond 36 | [(empty? optional-loa+content) '() ] 37 | [else (local ((define may_attributes (first optional-loa+content))) 38 | (if (list_of_attributes? may_attributes) 39 | (rest optional-loa+content) 40 | optional-loa+content))]))) 41 | 42 | (define (xexpr-attributes xe) 43 | (local ((define optional-loa+content (rest xe))) 44 | (cond 45 | [(empty? optional-loa+content ) '()] 46 | [else 47 | (local ((define may_attributes (first optional-loa+content))) 48 | (if (list_of_attributes? may_attributes) 49 | may_attributes 50 | '()))]))) 51 | 52 | 53 | (define (render-enum xe) 54 | (local ((define content (xexpr-content xe)) 55 | ; XItem.v2 Image -> Image 56 | (define (deal-with-one-item fst-itm so-far) 57 | (above/align 'left (render-item fst-itm) so-far))) 58 | (foldr deal-with-one-item empty-image content))) 59 | 60 | (define (render-item an-item) 61 | (local ((define content (first (xexpr-content an-item)))) 62 | (beside/align 63 | 'center BULLET 64 | (cond 65 | [(word? content) (text (word-text content) SIZE 'black)] 66 | [else (render-enum content)])))) 67 | ; XItem.v2 -> Image 68 | ; renders one XItem.v2 as an image 69 | 70 | (define e0 '(ul ((kk "u")) (li (word ((text "one")))))) 71 | (define e1 '(li (word ((text "one"))))) 72 | 73 | ; XEnum.v2 -> Image 74 | ; renders an XEnum.v2 as an image 75 | 76 | (check-expect 77 | (render-enum e0) 78 | (bulletize (text "one" SIZE COLOR))) 79 | 80 | 81 | (check-expect 82 | (render-item e1) 83 | (bulletize (text "one" SIZE COLOR))) 84 | 85 | (render-enum '(ul (li (word ((text "123")))) 86 | (li (ul (li (word ((text "456")))))))) 87 | -------------------------------------------------------------------------------- /HTDP/list-excercise.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname list-excercise) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp")) #f))) 4 | (define (sum l) 5 | (cond 6 | [(empty? l) 0] 7 | [else (+ (first l) (sum (rest l)))])) 8 | ;;相比前者速度更快，计算的步骤更少 9 | (define (sum.2 l) 10 | (cond 11 | [(empty? (rest l)) (first l)] 12 | [(cons? (rest l)) (+ (first l) (sum.2 (rest l)))])) 13 | (define (sort>? l) 14 | (cond 15 | [(empty? (rest l)) true] 16 | [else (and (> (first l) (first (rest l))) (sort>? (rest l)) )])) 17 | (check-expect (sort>? (cons 9 (cons 8 (cons 1 '())))) true ) 18 | (define (how-many l) 19 | (cond 20 | [(empty? (rest l)) 1 ] 21 | [else (+ 1 (how-many (rest l)))])) 22 | (check-expect (how-many (cons 9 (cons 8 (cons 1 '())))) 3) 23 | (define (all-true l) 24 | (cond 25 | [(empty? (rest l)) (first l)] 26 | [else (and (first l) (all-true (rest l)))])) 27 | 28 | (define (copier n l) 29 | (cond 30 | [(zero? n) '()] 31 | [(positive? n) (cons l (copier (sub1 n) l))] 32 | [(not (integer? n)) (error "请输入正整数")])) 33 | 34 | (define (add-to-pi n) 35 | (+ n pi)) 36 | (check-within (add-to-pi 3) (+ 3 pi) 0.001) 37 | (define (multiply n x) 38 | (cond 39 | [(zero? n) 1] 40 | [(positive? n) (* x (multiply (sub1 n) x))] 41 | [(not (integer? n)) (error "请输入整数")])) 42 | (define (col n img) 43 | (cond 44 | [(zero? (sub1 n)) img] 45 | [(positive? (sub1 n)) (above img (col (sub1 n) img ))])) 46 | (define (row n img) 47 | (cond 48 | [(zero? (sub1 n)) img] 49 | [(positive? (sub1 n)) (beside img (row (sub1 n) img ))])) 50 | (check-expect (multiply 10 2) 1024) 51 | (define Background (row 8 (col 18 (empty-scene 10 10)))) 52 | (define Ball (circle 5 "solid" "red")) 53 | (define (play l) 54 | (cond 55 | [(empty? (rest l)) (place-image Ball (posn-x (first l)) (posn-y (first l)) Background) ] 56 | [else (place-image Ball (posn-x (first l)) (posn-y (first l)) (play (rest l)))])) 57 | 58 | (play (cons (make-posn 20 30) (cons (make-posn 30 40) (cons (make-posn 40 60) '())) )) -------------------------------------------------------------------------------- /HTDP/list-world-shot.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname list-world-shot) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp")) #f))) 4 | ;;物理常量 5 | (define Height 80) 6 | (define Width 100) 7 | (define Xshots (/ Width 2)) 8 | 9 | ;;图片常量 10 | (define Background (empty-scene Width Height)) 11 | (define Shot (triangle 6 "solid" "red")) 12 | 13 | ;;a list of shot is one of 14 | ;-'() 15 | ;-(cons shot list-of-shots) 16 | 17 | ;posn->T/F 18 | ;decide wheather a posn is in the canvas or not 19 | (define (in-rich? p) 20 | (if (and (<= 0 (posn-x p) Width) (<= 0 (posn-y p) Height)) true false)) 21 | (define (key-hander l k) 22 | (cond 23 | [(key=? " " k) (cons (make-posn Xshots Height) l)] 24 | [else l])) 25 | 26 | (define (drawer l) 27 | (cond 28 | [(empty? l) 29 | Background] 30 | [(cons? l) 31 | (place-image Shot (posn-x (first l)) (posn-y (first l)) (drawer (rest l)) )] 32 | [else 33 | l])) 34 | 35 | (define (time-hander l) 36 | (cond 37 | [(empty? l) '()] 38 | [(cons? l) 39 | (if (in-rich? (first l)) 40 | (cons (make-posn Xshots (sub1 (posn-y (first l)))) (time-hander (rest l))) 41 | (time-hander (rest l)))] 42 | [else l])) 43 | 44 | (define (main l) 45 | (big-bang l 46 | [to-draw drawer] 47 | [on-key key-hander] 48 | [on-tick time-hander] 49 | )) 50 | (main '()) -------------------------------------------------------------------------------- /HTDP/no-artical-ttt.dat: -------------------------------------------------------------------------------- 1 | TTT 2 | 3 | Put up in place 4 | where it's easy to see 5 | cryptic admonishment 6 | T.T.T. 7 | 8 | When you feel how depressingly 9 | slowly you climb, 10 | it's well to remember that 11 | Things Take Time. 12 | 13 | Piet Hein 14 | -------------------------------------------------------------------------------- /HTDP/out.txt: -------------------------------------------------------------------------------- 1 | 2 | Exercise 485. Design the function split. 3 | Use the accumulator design recipe to im 4 | prove on the result of exercise 484. Aft 5 | er all, the hints already point out that 6 | when the function discovers the correct 7 | split point, it needs both parts of the 8 | list and one part is obviously lost due 9 | to recursion. image 10 | 11 | Once you have solv 12 | ed this exercise, equip the main functio 13 | n of A Graphical Editor, Revisited with 14 | a clause for mouse clicks. As you experi 15 | ment with moving the cursor via mouse cl 16 | icks, you will notice that it does not e 17 | xactly behave like applications that you 18 | use on your other devices—even though s 19 | plit passes all its tests. 20 | 21 | Graphical pr 22 | ograms, like editors, call for experimen 23 | tation to come up with best “look and fe 24 | el” experiences. In this case, your edit 25 | or is too simplistic with its placement 26 | of the cursor. After the applications on 27 | your computer determine the split point 28 | , they also determine which letter divis 29 | ion is closer to the x-coordinate and place the cursor there. -------------------------------------------------------------------------------- /HTDP/parse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (define WRONG "错误的s表达式") 3 | 4 | ;用来处理单纯的加法和乘法 5 | (define-struct add [left right]) 6 | (define-struct mul [left right]) 7 | (define (atom? s) 8 | (cond 9 | [(or (number? s) 10 | (string? s) 11 | (symbol? s)) 12 | true] 13 | [else false])) 14 | 15 | (define-struct def [name para body]) 16 | (define (parse s) 17 | (local (;S-expr -> BSL-expr 18 | (define (parse s) 19 | (cond 20 | [(atom? s) (parse-atom s)] 21 | [else (parse-sl s)])) 22 | ;SL -> BSL-expr 23 | (define (parse-sl s) 24 | (local ((define l (length s))) 25 | (cond 26 | [(< l 3) (error WRONG)] 27 | [(and (= l 3) (symbol? (first s))) 28 | (cond 29 | [(symbol=? (first s) '+) 30 | (make-add (parse (second s)) (parse (third s)))] 31 | [(symbol=? (first s) '*) 32 | (make-mul (parse (second s)) (parse (third s)))] 33 | [else (error WRONG)])] 34 | [else (error WRONG)]))) 35 | ;Atom->BSL-expr 36 | (define (parse-atom s) 37 | (cond 38 | [(number? s) s] 39 | [(string? s) (error "不可以是字符串")] 40 | [(symbol? s) (error "不可以是标记(symbol)")])) 41 | ) 42 | (parse s))) 43 | 44 | (define (subst ex x v) 45 | (cond 46 | [(empty? ex) '()] 47 | [(symbol=? x (first ex)) (cons v (rest ex))] 48 | [else (cons (first ex) (subst (rest ex) x v))])) 49 | 50 | (define (numberic? ex x v) 51 | (local ( 52 | ;;替换symbol为 53 | (define ex2 (subst ex x v)) 54 | ) 55 | (if (or (mul? (parse ex2)) 56 | (add? (parse ex2))) 57 | true 58 | false))) 59 | 60 | (define (parse2 x) 61 | (parse (subst x 's 7))) 62 | 63 | 64 | 65 | 66 | 67 | ;S-expression -> BSL-fun-def 68 | ;将s表达式转换成BSL(if possible) 69 | (define (def-parse s) 70 | (local ( 71 | ;S-expression ->BSL-expression 72 | (define (def-parse s) 73 | (cond 74 | [(atom? s) (error WRONG)] 75 | [else 76 | (if (and (= 3 (length s)) (eq? 'define (first s)) ) 77 | (head-parse (second s) (parse (third s))) 78 | (error WRONG))])) 79 | 80 | (define (head-parse s body) 81 | (cond 82 | [(atom? s) (error WRONG)] 83 | [else 84 | (if (not (= (length s) 2)) 85 | (error WRONG) 86 | (local 87 | ( 88 | (define name (first s)) 89 | (define para (second s)) 90 | ) 91 | (if (and (symbol? name) (symbol? para)) 92 | (make-def name para body) 93 | (error WRONG)) 94 | ))])) 95 | ) 96 | (def-parse s))) 97 | 98 | (def-parse '(define x 7)) 99 | -------------------------------------------------------------------------------- /HTDP/rocket-launch.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname rocket-launch) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t write repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp"))))) 4 | ;;物理设定 5 | (define HEIGHT 300) 6 | (define WIDTH 100) 7 | (define YDELTA 3);; 8 | 9 | ;;图片常量 10 | (define BACKG (empty-scene WIDTH HEIGHT));;背景 11 | (define ROCKET (rectangle 5 30 "solid" "red")) 12 | (define ROCKET-CENTER (/ (image-height ROCKET) 2)) 13 | (define X-ROCKET (/ WIDTH 2)) 14 | 15 | (define (place-rocket y) 16 | (place-image ROCKET X-ROCKET y BACKG)) 17 | 18 | (define (show x) 19 | (cond 20 | [(string? x) 21 | (place-rocket (- HEIGHT ROCKET-CENTER))] 22 | [(<= -3 x -1) 23 | (place-image (text (number->string x) 20 "red") 24 | 10 (* 3/4 WIDTH) 25 | (place-rocket (- HEIGHT ROCKET-CENTER) ))] 26 | [(>= x 0) 27 | (place-rocket (- HEIGHT x ROCKET-CENTER) )])) 28 | 29 | (define (launch x ke) 30 | (cond 31 | [(string? x) 32 | (if (string=? " " ke) -3 x)] 33 | [(<= -3 x -1) x ] 34 | [(>= x 0) x])) 35 | 36 | (define (fly x) 37 | (cond 38 | [(string? x) x] 39 | [(<= -3 x -1) (+ x 1)] 40 | [(>= x 0) (+ x YDELTA)])) 41 | (define (stop x) 42 | (cond 43 | [(string? x) false] 44 | [(>= x HEIGHT) true] 45 | [else false])) 46 | 47 | (define (main s) 48 | (big-bang s 49 | [to-draw show] 50 | [on-key launch] 51 | [on-tick fly ] 52 | [stop-when stop])) 53 | 54 | (main "resting") -------------------------------------------------------------------------------- /HTDP/testxml.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require 3 | 2htdp/batch-io 4 | 2htdp/universe 5 | 2htdp/image 6 | "25-XML.rkt") 7 | 8 | (define company "ford") 9 | (define PREFIX "https://www.google.com/finance?q=") 10 | (define SUFFIX "&btnG=Search") 11 | 12 | (define url (string-append PREFIX company SUFFIX)) 13 | 14 | (define x (read-xexpr/web url) ) 15 | 16 | -------------------------------------------------------------------------------- /HTDP/toBeContinue.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname toBeContinue) (read-case-sensitive #t) (teachpacks ((lib "universe.rkt" "teachpack" "2htdp") (lib "image.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.rkt" "teachpack" "2htdp") (lib "image.rkt" "teachpack" "2htdp"))))) 4 | ; A UFO is a structure: (make-ufo Posn Vel) 5 | ; interpretation (make-ufo p v) is at location p moving at velocity v 6 | ; For Vel, see above. 7 | (define-struct ufo [loc vel]) 8 | (define-struct vel [x y]) 9 | 10 | 11 | (define v1 (make-vel 8 -3)) 12 | (define v2 (make-vel -5 -3)) 13 | 14 | (define p1 (make-posn 22 80)) 15 | (define p2 (make-posn 30 77)) 16 | 17 | (define u1 (make-ufo p1 v1)) 18 | (define u2 (make-ufo p1 v2)) 19 | (define u3 (make-ufo p2 v1)) 20 | (define u4 (make-ufo p2 v2)) 21 | 22 | ; UFO -> UFO 23 | ; determines where u moves in one clock tick; 24 | ; leaves the velocity as is 25 | (define (ufo-move-1 u) u) 26 | (check-expect (ufo-move-1 u1) u3) 27 | (check-expect (ufo-move-1 u2) (make-ufo (make-posn 17 77) v2)) 28 | 29 | -------------------------------------------------------------------------------- /HTDP/trafic light.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname |trafic light|) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t write repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp"))))) 4 | (define (next s) 5 | (cond 6 | [(string=? "red" s) "green"] 7 | [(string=? "green" s) "yellow"] 8 | [(string=? "yellow" s) "red"] 9 | [else "red"])) 10 | (define (draw s) (circle 30 "solid" s)) 11 | ;;刚开始的时候是黑色的，我没有工程师朋友。 12 | (big-bang "black" 13 | (to-draw draw) 14 | (on-tick next 1)) -------------------------------------------------------------------------------- /HTDP/ttt.dat: -------------------------------------------------------------------------------- 1 | TTT 2 | 3 | Put up in a place 4 | where it's easy to see 5 | the cryptic admonishment 6 | T.T.T. 7 | 8 | When you feel how depressingly 9 | slowly you climb, 10 | it's well to remember that 11 | Things Take Time. 12 | 13 | Piet Hein 14 | -------------------------------------------------------------------------------- /HTDP/ttt.txt: -------------------------------------------------------------------------------- 1 | TTT 2 | 3 | Put up in a place 4 | where it's easy to see 5 | the cryptic admonishment 6 | T.T.T. 7 | 8 | When you feel how depressingly 9 | slowly you climb, 10 | it's well to remember that 11 | Things Take Time. 12 | 13 | Piet Hein 14 | -------------------------------------------------------------------------------- /HTDP/ufo-land.rkt: -------------------------------------------------------------------------------- 1 | ;; The first three lines of this file were inserted by DrRacket. They record metadata 2 | ;; about the language level of this file in a form that our tools can easily process. 3 | #reader(lib "htdp-beginner-reader.ss" "lang")((modname ufo-land) (read-case-sensitive #t) (teachpacks ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp"))) (htdp-settings #(#t write repeating-decimal #f #t none #f ((lib "image.rkt" "teachpack" "2htdp") (lib "universe.rkt" "teachpack" "2htdp") (lib "batch-io.rkt" "teachpack" "2htdp"))))) 4 | ; WorldState is a Number 5 | ; interpretation height of UFO (from top) 6 | 7 | ; constants: 8 | (define WIDTH 300) 9 | (define HEIGHT 100) 10 | (define CLOSE (/ HEIGHT 3)) 11 | 12 | ; visual constants: 13 | (define MT (empty-scene WIDTH HEIGHT)) 14 | 15 | 16 | (define UFO 17 | (overlay (circle 10 "solid" "green") 18 | (rectangle 40 2 "solid" "green"))) 19 | 20 | ; WorldState -> WorldState 21 | (define (main y0) 22 | (big-bang y0 23 | [on-tick nxt ] 24 | [to-draw render] 25 | [stop-when touch])) 26 | 27 | ; WorldState -> WorldState 28 | ; computes next location of UFO 29 | (define (nxt y) 30 | (+ y 1)) 31 | 32 | ; WorldState -> Image 33 | ; place UFO at given height into the center of MT 34 | 35 | (define (render y) 36 | (place-image (text (lable y) 12 "indigo") (/ WIDTH 2) 10 (place-image UFO (/ WIDTH 2) y MT))) 37 | 38 | (define (touch y0) (if (> (+ y0 0) HEIGHT) true false)) 39 | 40 | (define (lable y0) (cond [(< y0 CLOSE) "descending"] [(and (>= y0 CLOSE) (< y0 HEIGHT)) "closing in"] [(>= y0 HEIGHT) "landed"])) 41 | 42 | (main 0) 43 | -------------------------------------------------------------------------------- /HTDP/ufoMove.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; ufo 设定位置和速度 3 | (define-struct ufo [loc vel]) 4 | (define-struct vle [x y]) 5 | ;;ufo->ufo 6 | ;;将速度加到位置上 7 | 8 | ;;vel posn ->posn 9 | ;;将速度加到位置上去 10 | 11 | (define (posn+ p v) 12 | (make-posn (+ (posn-x p) (vel-x v)) 13 | (+ (posn-y p) (vel-y v)))) 14 | (define (ufo-move u) 15 | (posn+ (ufo-loc u) (ufo-vel u))) 16 | 17 | -------------------------------------------------------------------------------- /HTDP/间奏-计算的成本.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;Exercise 458 4 | ;不使用local定义的inf 5 | ;inf 的作用和max min差不多 6 | (define (inf l) 7 | (cond 8 | [(empty? (rest l)) (first l)] 9 | [else (if (> (first l) (inf (rest l))) 10 | (first l) 11 | (inf (rest l)))])) 12 | 13 | ;时间消耗为2^n 不要轻易解注下一行代码 14 | ;; (inf (range 100)) 15 | 16 | (define (infL l) 17 | (cond 18 | [(empty? (rest l)) (first l)] 19 | [else (local ((define x (infL (rest l)))) 20 | (if (> (first l) x) (first l) x))])) 21 | 22 | ;改良版,效率感人 23 | ;; (infL (range 100000)) 24 | 25 | ;;number tree 26 | ;is one of 27 | ;--'() 28 | ;-- number 29 | ;-- (number-tree '()) 30 | 31 | 32 | ;[number tree]==> Number 33 | (define (sum-tree nt) 34 | (cond 35 | [(number? nt) nt] 36 | [(empty? nt) 0] 37 | [(cons? nt) (+ (sum-tree (first nt)) (sum-tree (rest nt)))])) 38 | 39 | ;; (sum-tree (list (range 101))) 40 | ;; (foldr + 0 (range 101)) 41 | 42 | 43 | 44 | (define (searchL x l) 45 | (cond 46 | [(empty? l) #false] 47 | [else 48 | (or (= (first l) x) 49 | (searchL x (rest l)))])) 50 | ;;length 异常消耗时间 51 | (define (searchS x l) 52 | (cond 53 | [(= (length l) 0) #false] 54 | [else 55 | (or (= (first l) x) 56 | (searchS x (rest l)))])) 57 | 58 | ; N -> [List Boolean Boolean] 59 | ; how long do searchS and searchL take 60 | ; to look for n in (list 0 ... (- n 1)) 61 | (define (timing n) 62 | (local ((define long-list (build-list n (lambda (x) x)))) 63 | (list 64 | (time (searchS n long-list)) 65 | (time (searchL n long-list))))) 66 | 67 | ;; (timing 100000) 68 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright © 2016 shenxs 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the "Software"), 5 | to deal in the Software without restriction, including without limitation 6 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 7 | and/or sell copies of the Software, and to permit persons to whom the 8 | Software is furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included 11 | in all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 14 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 15 | OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 16 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, 17 | DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 18 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE 19 | OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 20 | 21 | -------------------------------------------------------------------------------- /Macros/FearOfMacros2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;之前的文件有点长了，所以新建一个 3 | 4 | ;;之前的两个例子中，我们用两个标识符加“-”来构建自己的函数 5 | ;我们还自定义了struct类 6 | ;之前是将一小片一小片的语法碎片拼接，接下来试试看将一个语法元素展开 7 | 8 | 9 | ;如果你的程序和互联网打交道，你就回经常碰到一些json数据 10 | ;在racket中用jsexpr?来表示 11 | ;在一个json字典中通常会包含另一个字典，他们都使用 hashep来表示 12 | 13 | ;;哈希表 14 | ;(hash key val ... ...) 15 | ;key any/c 16 | ;val any/c 17 | ;还有hasheq 18 | ;hasheqv 19 | ;区别是 20 | ;equal? eq? eqv? 用来比较key的方式不同 21 | ;; (equal? 1 1) 22 | ;; (eq? 1 1) 23 | ;; (eqv? 1 1) 24 | ;; (struct posn [x y]) 25 | ;; (define a (posn 1 2)) 26 | ;; (define b (posn 1 2)) 27 | ;; (equal? a b) 28 | ;; (eq? a b) 29 | ;; (eqv? a b) 30 | 31 | ;; (equal? 2 2.0) 32 | 33 | ;;eq? 只有当两个比较的东西是同一个对象之后，他们才是相等的 34 | 35 | ;; (hash 'q "df" 4 "fjjf" 'y "jfjf") 36 | 37 | (define js (hasheq 'a (hasheq 'b (hasheq 'c "终于找到了")))) 38 | 39 | 40 | ;; (hash-ref js 'a) 41 | ;;由于嵌套的原因，我们可以一层一层的取出来，可是这么做在语法上过于啰嗦 42 | ;可以借鉴其他语言的dot的方式 js.a.b.c来实现吗？ 43 | 44 | ;;辅助函数 45 | (define/contract (hash-refs h ks [def #f]) 46 | ((hash? (listof any/c)) (any/c) . ->* . any ) 47 | (with-handlers ([exn:fail? (const (cond [(procedure? def) (def)] 48 | [else def]))]) 49 | (for/fold ([h h]) 50 | ([k (in-list ks)]) 51 | (hash-ref h k) 52 | ))) 53 | 54 | (hash-refs js '(a b c) ) 55 | 56 | 57 | (require (for-syntax racket/syntax)) 58 | 59 | (define-syntax (hash.refs stx) 60 | (syntax-case stx () 61 | [(_ chain) #'(hash.refs chain #f)] 62 | [(_ chain default) 63 | (let* ([chain-str (symbol->string (syntax->datum #'chain))] 64 | [ids (for/list ([str (in-list (regexp-split #rx"\\." chain-)]))]))])) 65 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # HTDP-exercise 2 | 这里面已经不止《HTDP》的内容了,以后就作为我学习Racket(lisp/scheme)的记录吧 3 | ## 已经完成 4 | -《How to Design Program》学习练习的记录 5 | - racket 的学习练习记录，多为书上的exercise的记录。 6 | - 添加了王垠.《怎么写一个解释器》的代码，精彩的文章 7 | - 试着自己推导Y组合子，依然似懂非懂 8 | - 完全使用匿名函数，使用匿名函数实现递归 9 | - 添加了[FearOfMacros](http://www.greghendershott.com/fear-of-macros/)的内容 10 | - [buildyourownlisp](http://www.buildyourownlisp.com/) 写一个简单的lisp解释器 11 | - BP 包含一个简单的梯度下降，反向传播的网络 12 | 13 | ## 计划之中 14 | - 《The Little Schemer》 15 | 粗略地看过一遍,但是并没有敲过，总感觉缺了点什么 16 | -------------------------------------------------------------------------------- /TSPL/2.7-Assignment.ss: -------------------------------------------------------------------------------- 1 | ;;racket和chez的语法有些不一样 2 | ;;一些代码写在这里因为racket无法运行或者需要额外的包,和已有的冲突 3 | 4 | 5 | 6 | (define make-queue 7 | (lambda () 8 | (let ([end (cons 'ignore '())]) 9 | (cons end end)))) 10 | 11 | (define putq! 12 | (lambda (q v) 13 | (let ([end (cons 'ignore '())]) 14 | (set-car! (cdr q) v) 15 | (set-cdr! (cdr q) end) 16 | (set-cdr! q end)))) 17 | 18 | (define getq! 19 | (lambda (q) 20 | (if (emptyq? q) 21 | (assertion-violation 'getq! "队列为空" q) 22 | (car (car q))))) 23 | 24 | 25 | (define delq! 26 | (lambda (q) 27 | (if (emptyq? q) 28 | (assertion-violation 'delq! "队列为空" q) 29 | (set-car! q (cdr (car q)))))) 30 | 31 | 32 | (define myq (make-queue)) 33 | 34 | (putq! myq 'a) 35 | 36 | (putq! myq 'b) 37 | 38 | (getq! myq) 39 | 40 | (delq! myq) 41 | 42 | (getq! myq) 43 | 44 | 45 | ;;Exercise 2.9.5 46 | 47 | (define emptyq? 48 | (lambda (q) 49 | (if (> (length (car q)) 1) 50 | #f #t))) 51 | 52 | (define myq2 (make-queue)) 53 | 54 | (putq! myq2 'a) 55 | 56 | (delq! myq2) 57 | 58 | (emptyq? myq2) 59 | 60 | (getq! myq2) 61 | 62 | 63 | ;;2.9.6 64 | 65 | 66 | 67 | (define make-queue 68 | (lambda () 69 | (cons '() '()))) 70 | 71 | 72 | (define (putq! q v) 73 | (let ([p (cons v '())]) 74 | (if (null? (car q)) 75 | (begin 76 | (set-car! q p) 77 | (set-cdr! q p)) 78 | (begin 79 | (set-cdr! (cdr q) p) 80 | (set-cdr! q p))))) 81 | 82 | 83 | (define (getq! q) 84 | (car (car q))) 85 | 86 | (define (delq! q) 87 | (if (eq? (car q) (cdr q)) 88 | (begin 89 | (set-car! q '()) 90 | (set-cdr! q '())) 91 | (set-car! q (cdr (car q))))) 92 | 93 | (define myq (make-queue)) 94 | 95 | (putq! myq 'a) 96 | (putq! myq 'b) 97 | (putq! myq 'c) 98 | 99 | (delq! myq) 100 | 101 | ;;队列的实现来看 102 | ;;有占位符实现 103 | ;;罗辑一致添加和删除的时候没有特殊情况 104 | ;;浪费占位符的空间 105 | ;;插入的步骤需要3,删除1步 106 | 107 | 108 | ;;无占位符 109 | ;;处理的时候需要判断是否是空队列,是否队列里面只有一个元素 110 | ;;节省占位符空间 111 | ;;代码实现需要分类所以显得啰嗦 112 | ;;罗辑步骤更加简单 113 | 114 | 115 | 116 | (define (list? l) 117 | (cond 118 | [(null? l) #t] 119 | [(symbol? l) #f] 120 | [else (list? (cdr l))])) 121 | (list? '()) 122 | 123 | (list? '(1 2 3)) 124 | 125 | (list? '(a . b)) 126 | 127 | ;;2.9.8 128 | 129 | (define (race hare tortoise) 130 | (if (pair? hare) 131 | (let ([hare (cdr hare)]) 132 | (if (pair? hare) 133 | (and (not (eq? hare tortoise)) 134 | (race (cdr hare) (cdr tortoise))) 135 | (null? hare))) 136 | (null? hare))) 137 | 138 | 139 | (define list? 140 | (lambda (x) 141 | (race x x))) 142 | 143 | 144 | 145 | -------------------------------------------------------------------------------- /TSPL/3.1-语法扩展.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;let 是一个从λ定义出来的语法扩展 3 | 4 | ;语法是可以扩展的,其实没有太大必要区分核心语法和扩展语法 5 | 6 | ;编译器会先将扩展语法还原为核心语法 7 | 8 | ;核心语法包括 define 常量 变量 过程 quote表达式 λ表达式 if表达式 set!表达式 9 | 10 | 11 | ;;TODO f5运行 和在repl解释的结果不太一样 12 | (begin 'a 'b 'c) 13 | ;可以转化为 14 | ((lambda () 'a 'b 'c)) 15 | 16 | 17 | ;; ...允许0个或者是更多的表达式 18 | 19 | (define-syntax and 20 | (syntax-rules () 21 | [(_) #t] 22 | [(_ e) e] 23 | [(_ e1 e2 e3 ...) 24 | (if e1 25 | (and e2 e3 ...) 26 | #f)])) 27 | 28 | ;; 或表达式 29 | 30 | (define-syntax or 31 | (syntax-rules () 32 | [(_) #f] 33 | [(_ e) e] 34 | [(_ e1 e2 e3 ...) 35 | (if e1 e1 (or e2 e3 ...))])) 36 | 37 | (or (begin (display "hello") 38 | #t) 39 | #f) 40 | 41 | ;; 42 | (define-syntax or 43 | (syntax-rules () 44 | [(_) #f] 45 | [(_ e) e] 46 | [(_ e1 e2 e3 ...) 47 | (let ([t e1]) 48 | (if t t (or e2 e3 ...)))])) 49 | 50 | ;;多了一句let为什么要多一层 TODO 51 | 52 | ;;3.1.1 53 | 54 | 55 | ((lambda (x) (and x (memv 'b x))) (memv 'a ls)) 56 | 57 | ((lambda (x) (if x (memv 'b x) #f)) (memv 'a ls)) 58 | 59 | 60 | ;;3.1.2 61 | 62 | (or (memv x '(a b c)) (list x)) 63 | 64 | ;;====> 65 | 66 | (let ([t (memv x '(a b c))]) 67 | (if t t (list x))) 68 | 69 | ;;多一层是为了防止副作用吗? 70 | ;;是的 71 | (let ([t (begin (display "hello") 72 | #f)]) 73 | (if t t "world")) 74 | 75 | ;;3,1,3 76 | 77 | 78 | (define-syntax let* 79 | (syntax-rules () 80 | [(_ ([v e]) 81 | t) 82 | (let ([v e]) 83 | t)] 84 | [(_ ([v0 e0] [v1 e1] [v2 e2] ...) 85 | t) 86 | (let ([v0 e0]) 87 | (let* ([v1 e1] [v2 e2] ...) 88 | t))])) 89 | 90 | (let* ([a 5] 91 | [b (+ a a)] 92 | [c (+ a b)]) 93 | (list a b c)) 94 | 95 | 96 | 97 | ;;3.1.4 98 | 99 | 100 | 101 | (define-syntax when 102 | (syntax-rules () 103 | [(_ test exp1 exp2 ...) 104 | (if test (begin exp1 exp2 ...) (void))])) 105 | 106 | (define-syntax unless 107 | (syntax-rules () 108 | [(_ test exp1 exp2 ...) 109 | (when (not test) exp1 exp2 ...)])) 110 | 111 | (let ([x 3]) 112 | (unless (= x 0) (set! x (+ x 1))) 113 | (when (= x 4) (set! x (* x 2))) 114 | x) 115 | -------------------------------------------------------------------------------- /TSPL/3.1-语法扩展.ss: -------------------------------------------------------------------------------- 1 | (begin 'a 'b 'c) 2 | 3 | 4 | ;;3.3.1 5 | (define-syntax let* 6 | (syntax-rules () 7 | [(_ ([v e]) 8 | t) 9 | (let ([v e]) 10 | t)] 11 | [(_ ([v0 e0] [v1 e1] [v2 e2] ...) 12 | t) 13 | (let ([v0 e0]) 14 | (let* ([v1 e1] [v2 e2] ...) 15 | t))])) 16 | 17 | (let* ([a 5] 18 | [b (+ a a)] 19 | [c (+ a b)]) 20 | (list a b c)) 21 | -------------------------------------------------------------------------------- /TSPL/3.2-更多递归.ss: -------------------------------------------------------------------------------- 1 | (define (fibonacci-i n) 2 | (letrec ([f (lambda (i a b) 3 | (cond 4 | [(= i 1) b] 5 | [else (f (sub1 i) b (+ a b))]))]) 6 | (f n 0 1))) 7 | 8 | (fibonacci-i 100) 9 | 10 | (define make-counter 11 | (lambda () 12 | (let ([x 0]) 13 | (lambda () 14 | (let ([t x]) 15 | (begin 16 | (set! x (+ x 1)) 17 | t)))))) 18 | 19 | 20 | (define c1 (make-counter)) 21 | 22 | (define (fibnacci n) 23 | (letrec ([f (lambda (a b n) 24 | (begin (c1) 25 | (cond 26 | [(= n 0) b] 27 | [else (f b (+ a b) (- n 1))])))]) 28 | (f 0 1 n))) 29 | 30 | (fibnacci 20) 31 | 32 | (c1) 33 | 34 | ;;3.2.6 35 | ;;并不是尾递归,有可能消耗大量的空间 36 | (define-syntax or 37 | (syntax-rules () 38 | [(_) #f] 39 | [(_ e1 e2 ...) 40 | (let ([t e1]) 41 | (if t t (or e2 ...)))])) 42 | 43 | 44 | (or 1 ) 45 | 46 | (letrec ([even? 47 | (lambda (x) 48 | (or (= x 0) 49 | (odd? (- x 1))))] 50 | [odd? 51 | (lambda (x) 52 | (and (not (= x 0)) 53 | (even? (- x 1))))]) 54 | (list (even? 100000000000) (odd? 1000))) 55 | 56 | -------------------------------------------------------------------------------- /TSPL/3.3-continuations.ss: -------------------------------------------------------------------------------- 1 | 2 | ((call/cc (lambda (k) k)) (lambda (x) x)) 3 | -------------------------------------------------------------------------------- /TSPL/3.3.1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;使用call/cc写一个无限循环程序,打印一个从0开始的数字序列 3 | ;;不能使用递归,不能使用任何赋值操作 4 | 5 | (let ([k.n (call/cc (lambda (k) (cons k 0)))]) 6 | (let ([k (car k.n)] 7 | [n (cdr k.n)]) 8 | (displayln n) 9 | (k (cons k (+ n 1))))) 10 | -------------------------------------------------------------------------------- /TSPL/3.3.2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;不使用call/cc重写product,使其保持特性,在遇到0的时候停止运算 4 | 5 | 6 | (define (product ls) 7 | (cond 8 | [(empty? ls) 1] 9 | [(= 0 (car ls)) 0] 10 | [else (let ([next (product (cdr ls))]) 11 | (* (car ls) next))])) 12 | 13 | (product '(1 2 3 4 5 6)) 14 | (product '(1 2 3 0 x y z)) 15 | -------------------------------------------------------------------------------- /TSPL/3.3.3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define lwp-list '()) 4 | (define quit-k #f) 5 | (define lwp 6 | (lambda (thunk) 7 | (set! lwp-list (append lwp-list (list thunk))))) 8 | 9 | (define (start) 10 | (call/cc 11 | (lambda (k) 12 | (set! quit-k k) 13 | (next)))) 14 | 15 | (define (next) 16 | (let ([p (car lwp-list)]) 17 | (set! lwp-list (cdr lwp-list)) 18 | (p))) 19 | 20 | (define pause 21 | (lambda () 22 | (call/cc 23 | (lambda (k) 24 | (lwp (lambda () (k #f))) 25 | (next))))) 26 | 27 | (define (quit v) 28 | (if (empty? lwp-list) 29 | (quit-k v) 30 | (next))) 31 | 32 | (lwp (lambda () (let f () (pause) (display "h") (quit #f) (f)))) 33 | (lwp (lambda () (let f () (pause) (display "e") (quit #f) (f)))) 34 | (lwp (lambda () (let f () (pause) (newline) (quit #f) (f)))) 35 | 36 | ;;如果lwp中的进程要退出,例如直接退出不调用pause 37 | ;;定义一个退出函数 quit,允许进程退出而不会影响lwp系统的运行 38 | ;;注意考虑lwp中只剩下一个进程的情况 39 | 40 | ;;任务退出相当于不在把自己的延续加入任务队列,所以结构和pause相似,少了(lwp (lambda () (k #f))) 41 | (start) 42 | -------------------------------------------------------------------------------- /TSPL/3.3.5.ss: -------------------------------------------------------------------------------- 1 | (import (scheme)) 2 | ;;lwp使用了set!和append,每一次都会把lwp-list全部复制一份 3 | ;;请使用队列数据类型改写来避免这样的问题 4 | 5 | (define make-queue 6 | (lambda () 7 | (let ([end (cons 'ignored '())]) 8 | (cons end end)))) 9 | 10 | (define putq! 11 | (lambda (q v) 12 | (let ([end (cons 'ignored '())]) 13 | (set-car! (cdr q) v) 14 | (set-cdr! (cdr q) end) 15 | (set-cdr! q end)))) 16 | 17 | (define getq 18 | (lambda (q) 19 | (car (car q)))) 20 | 21 | (define delq! 22 | (lambda (q) 23 | (set-car! q (cdr (car q))))) 24 | 25 | (define lwp-list (make-queue)) 26 | (define quit-k #f) 27 | (define lwp 28 | (lambda (thunk) 29 | (putq! lwp-list thunk))) 30 | 31 | (define (start) 32 | (call/cc 33 | (lambda (k) 34 | (set! quit-k k) 35 | (next)))) 36 | 37 | (define (next) 38 | (let ([p (getq lwp-list)]) 39 | (delq! lwp-list) 40 | (p))) 41 | 42 | (define pause 43 | (lambda () 44 | (call/cc 45 | (lambda (k) 46 | (lwp (lambda () (k #f))) 47 | (next))))) 48 | 49 | (define (quit v) 50 | (if (null? lwp-list) 51 | (quit-k v) 52 | (next))) 53 | 54 | ;; (lwp (lambda () (let f () (pause) (display "h") (quit #f) (f)))) 55 | ;; (lwp (lambda () (let f () (pause) (display "e") (quit #f) (f)))) 56 | ;; (lwp (lambda () (let f () (pause) (newline) (quit #f) (f)))) 57 | 58 | ;; (start) 59 | 60 | ;;轻量级的线程机制可以动态查创建新线程 61 | 62 | (define (lwp-new func) 63 | (lwp (lambda () (let f () (pause) (func) (f) )))) 64 | 65 | (lwp-new (lambda () (display "h"))) 66 | (lwp-new (lambda () (display "e"))) 67 | (lwp-new (lambda () (display "y"))) 68 | (lwp-new (lambda () (display "!"))) 69 | (lwp-new (lambda () (newline))) 70 | (start) 71 | 72 | -------------------------------------------------------------------------------- /TSPL/3.4.1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;使用cps重写倒数 3 | 4 | (define (reciprocal x success failure) 5 | (if (= x 0) 6 | (failure "gave a zero") 7 | (success ( / 1 x)))) 8 | 9 | (reciprocal 12 values (lambda (x) x)) 10 | (reciprocal 0 values values) 11 | -------------------------------------------------------------------------------- /TSPL/3.4.2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;使用cps重写retry 3 | 4 | (define retry #f) 5 | 6 | (define (factorial x k) 7 | (let f ([x x] [k k]) 8 | (if (= x 0) 9 | ((lambda () (set! retry k) (k 1))) 10 | (f (- x 1) (lambda (v) (k (* v x))))))) 11 | 12 | (factorial 3 (lambda (x) x)) 13 | -------------------------------------------------------------------------------- /TSPL/3.4.3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; 使用cps风格重写一下函数 4 | 5 | ;; (define reciprocals 6 | ;; (lambda (ls) 7 | ;; (call/cc 8 | ;; (lambda (k) 9 | ;; (map (lambda (x) 10 | ;; (if (= x 0) 11 | ;; (k "zero found") 12 | ;; (/ 1 x))) 13 | ;; ls))))) 14 | 15 | 16 | (define (reciprocals ls k) 17 | (let ([break k]) 18 | (let f ([ls ls] [k k]) 19 | (cond 20 | [(null? ls) (k '())] 21 | [(= 0 (car ls)) (break "zero found")] 22 | [else (f (cdr ls) (lambda (x) (k (cons (/ 1 (car ls)) x))))])))) 23 | 24 | (reciprocals '(1 2 0 34 5) values) 25 | (reciprocals '(1 2 3 1/2 3 4) values) 26 | 27 | -------------------------------------------------------------------------------- /TSPL/3.4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; 正如之前所讨论的，每一个表达式都有一个延续。 4 | ;; 确切地说，每一个过程调用都和延续联系在一起 5 | ;; 当一个过程通过非尾递归调用另一个过程，被调用的过程会收到一个隐式的延续 6 | ;; 这个延续是完成调用过程剩下的主体部份，以及返回调用过程的延续 7 | ;; 如果这个调用是尾部调用，被调用的过程会收到调用过程的延续 8 | ;; Continuation Passing Style 是一种编程的风格 简称cps 9 | 10 | ;; 我们可以通过将特定的"做什么"的写成一个明确的过程,作为一个参数传递给调用过程 11 | ;; 使得这个调用的延续显示化 12 | ;;这里f就是一个一个例子 13 | ;;对于f的调用的延续 被cons和'b一起组成了g的延续 14 | ;;g 的延续和h的延续是一样的,这个延续cons符号d和返回值 15 | (letrec ([f (lambda (x) (cons 'a x))] 16 | [g (lambda (x) (cons 'b (f x)))] 17 | [h (lambda (x) (g (cons 'c x)))]) 18 | (cons 'd (h '()))) 19 | 20 | ;;我们可以用明确的过程来代替这些隐式延续.这种风格叫做continuation-passing style或者CPS 21 | 22 | (letrec ([f (lambda (x k) (k (cons 'a x)))] 23 | [g (lambda (x k) 24 | (f x (lambda (v) (k (cons 'b v)))))] 25 | [h (lambda (x k) (g (cons 'c x) k))]) 26 | (h '() (lambda (v) (cons 'd v)))) 27 | 28 | ;; 和上一例子里面的隐式传递类似,明确的延续被传递给了h和g 29 | 30 | (lambda (v) (cons 'd v)) 31 | ;; 将'd和收到的v组合.类似的,传递给f的continuation 32 | 33 | ;(lambda (v) (k (cons 'b v))) 34 | ;;将b和收到的参数组合,将其交给g的continuation 35 | 36 | 37 | 38 | 39 | ;;使用cps风格编写的表达式通常来说会更加复杂,但是这种风格有一些有用的应用 40 | ;;cps可以向延续传递不止一个结果,因为实现延续的这个过程可以接受任意数量的参数 41 | 42 | 43 | (define (car&cdr p k) 44 | (k (car p) (cdr p))) 45 | 46 | (car&cdr '(a b c) 47 | (lambda (x y) (list y x))) 48 | 49 | (car&cdr '(a b c) cons) 50 | (car&cdr '(a b c) memv) 51 | 52 | 53 | ;; cps允许接收多个参数的过程接受两个分开的 "成功" 和 "失败" 的延续 54 | ;; 例如下面的整数除法 55 | 56 | 57 | (define integer-divide 58 | (lambda (x y success failure) 59 | (if (= y 0) 60 | (failure "divide by zero") 61 | (let ([q (quotient x y)]) 62 | (success q (- x (* q y))))))) 63 | 64 | (integer-divide 10 3 list (lambda (x) x)) 65 | 66 | (integer-divide 10 0 list (lambda (x) x)) 67 | 68 | ;; 明确的成功和失败的延续有时候可以避免将执行成功和执行失败分开的额外交流必要 69 | ;; 而且这让我们有可能对应不同风味的成功和失败有多个成功和多个失败的延续, 70 | ;; 每个可能性接收不同数量和类型的参数 71 | 72 | 73 | ;; 事实上cps的编程风格和call/cc编写的方式是可以相互转化的,任何使用call/cc的程序都可以使用 74 | ;; cps重写而不需要call/cc.但是需要将整个程序重写,有时候可能包括系统预设的一些函数. 75 | 76 | 77 | ;; 使用cps重写连乘函数 78 | 79 | (define (product ls k) 80 | (let ([break k]) 81 | (let f ([ls ls] [k k]) 82 | (cond 83 | [(null? ls) (k 1)] 84 | [(= (car ls) 0) (break 0)] 85 | [else (f (cdr ls) 86 | (lambda (x) 87 | (k (* (car ls) x))))])))) 88 | 89 | -------------------------------------------------------------------------------- /TSPL/3.5.1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;用语法扩展重写complain函数 4 | 5 | (define-syntax complain 6 | (syntax-rules () 7 | [(_ ek msg expr) (ek (list msg expr))])) 8 | 9 | -------------------------------------------------------------------------------- /TSPL/3.5.2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; 在calc的例子中错误延续ek在apply-op, complain, 和 do-calc.中传递 3 | ;; 尽可能向内移动这些定义消除对于ek参数的传递 4 | 5 | (define calc #f) 6 | (let () 7 | (set! calc 8 | (lambda (expr) 9 | ; grab an error continuation ek 10 | (call/cc 11 | (lambda (ek) 12 | (define do-calc 13 | (lambda (expr) 14 | (define complain 15 | (lambda (msg expr) 16 | (ek (list msg expr)))) 17 | (define apply-op 18 | (lambda ( op args) 19 | (op (do-calc (car args)) (do-calc (cadr args))))) 20 | (cond 21 | [(number? expr) expr] 22 | [(and (list? expr) (= (length expr) 3)) 23 | (let ([op (car expr)] [args (cdr expr)]) 24 | (case op 25 | [(add) (apply-op + args)] 26 | [(sub) (apply-op - args)] 27 | [(mul) (apply-op * args)] 28 | [(div) (apply-op / args)] 29 | [else (complain "invalid operator" op)]))] 30 | [else (complain "invalid expression" expr)]))) 31 | (do-calc expr)))))) 32 | 33 | (calc '(add 345 (sub 4 5))) 34 | -------------------------------------------------------------------------------- /TSPL/3.5.3.ss: -------------------------------------------------------------------------------- 1 | ;;使用 assertion-violation 重写 2 | (import (scheme)) 3 | (define calc #f) 4 | (let () 5 | (define do-calc 6 | (lambda (expr) 7 | (cond 8 | [(number? expr) expr] 9 | [(and (list? expr) (= (length expr) 3)) 10 | (let ([op (car expr)] [args (cdr expr)]) 11 | (case op 12 | [(add) (apply-op + args)] 13 | [(sub) (apply-op - args)] 14 | [(mul) (apply-op * args)] 15 | [(div) (apply-op / args)] 16 | [else (complain "invalid operator" op)]))] 17 | [else (complain "invalid expression" expr)]))) 18 | (define apply-op 19 | (lambda (op args) 20 | (op (do-calc (car args)) (do-calc (cadr args))))) 21 | (define complain 22 | (lambda (msg expr) 23 | (assertion-violation 'calc msg expr))) 24 | (set! calc 25 | (lambda (expr) 26 | (do-calc expr)))) 27 | 28 | (calc '(add 1 2 )) 29 | -------------------------------------------------------------------------------- /TSPL/3.5.4.ss: -------------------------------------------------------------------------------- 1 | (import (scheme)) 2 | (define calc #f) 3 | (let () 4 | (define do-calc 5 | (lambda (expr) 6 | (cond 7 | [(number? expr) expr] 8 | [(and (list? expr) (= (length expr) 2)) 9 | (let ([op (car expr)] [args (cdr expr)]) 10 | (case op 11 | [(minus) (apply-op - (cons 0 args))] 12 | [else (complain "invalid op" op)] 13 | ))] 14 | [(and (list? expr) (= (length expr) 3)) 15 | (let ([op (car expr)] [args (cdr expr)]) 16 | (case op 17 | [(add) (apply-op + args)] 18 | [(sub) (apply-op - args)] 19 | [(mul) (apply-op * args)] 20 | [(div) (apply-op / args)] 21 | [else (complain "invalid operator" op)]))] 22 | [else (complain "invalid expression" expr)]))) 23 | (define apply-op 24 | (lambda (op args) 25 | (op (do-calc (car args)) (do-calc (cadr args))))) 26 | (define complain 27 | (lambda (msg expr) 28 | (assertion-violation 'calc msg expr))) 29 | (set! calc 30 | (lambda (expr) 31 | (do-calc expr)))) 32 | 33 | (calc '(add 2 3)) 34 | (calc '(minus (add 5 2))) 35 | 36 | -------------------------------------------------------------------------------- /TSPL/3.5.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;在之前的章节中,讨论过顶层定义.定义也可以出现在lambda let 或者 letrec 的body之前 4 | ;; 在这时这些定义是属于函数体的局部定义 5 | 6 | (define f (lambda (x) (* x x))) 7 | (let ([x 3]) 8 | (define f (lambda (y) (+ y x))) 9 | (f 4)) 10 | (f 4) 11 | 12 | 13 | ;;局部定义可以相互递归调用 14 | 15 | (let () 16 | (define even? 17 | (lambda (x) 18 | (or (= x 0) 19 | (odd? (- x 1))))) 20 | (define odd? 21 | (lambda (x) 22 | (and (not (= x 0)) 23 | (even? (- x 1))))) 24 | (even? 20)) 25 | 26 | (define list? 27 | (lambda (x) 28 | (define race 29 | (lambda (h t) 30 | (if (pair? h) 31 | (let ([h (cdr h)]) 32 | (if (pair? h) 33 | (and (not (eq? h t)) 34 | (race (cdr h) (cdr t))) 35 | (null? h))) 36 | (null? h)))) 37 | (race x x))) 38 | 39 | ;;实际上,内部变量定义和letrec是基本上通用的。除了语法上的唯一的区别， 40 | ;;他们的区别是变量的定义是可以保证被从左向右解析的,但是letrec有可能以任何顺序解析 41 | ;; 所以我们不能将一个包含内部定义的lambda,let,letrec的函数体用letrec替代.但是我们可以使用letrec* 42 | ;; let*来保证从左向右的解析顺序 43 | 44 | #| 45 | (define var expr0) 46 | 47 | expr1 48 | expr2 49 | 50 | 51 | 和以下的表达式等价 52 | 53 | (letrec* ((var epr0) ...) expr1 expr2..) 54 | 55 | 反过来 一个letrec*的形式 56 | 57 | (letrec* ((var epr0) ...) expr1 expr2..) 58 | 可以被一个包含内部定义的let表达式替代 59 | 60 | (let () 61 | (define var expr0) 62 | ... 63 | expr1 64 | expr2) 65 | 66 | 在这些变换中似乎缺少对称性.因为letrec* 表达式可以出现在一个合法表达式的任何位置 67 | 而内部定义只能出现在函数体前面.所以在使用内部定义替代letrec*的时候我们通常使用let表达式来 68 | 包裹define表达式 69 | 70 | 内部定义的另一个不同是,语法定义有可能出现在内部定义中,而letrec* 只是绑定变量 71 | 72 | |# 73 | (let ([x 3]) 74 | (define-syntax set-x! 75 | (syntax-rules () 76 | [(_ e) (set! x e)])) 77 | (set-x! (+ x x)) 78 | x) 79 | 80 | 81 | #| 82 | 使用内部定义的语法扩展的作用域也只限于内部定义所在的函数体中,就像定义一个变量一样 83 | 84 | 内部定义也许可以和顶层定义以及赋值联合起来帮助模块化程序 85 | 每个模块应该只将被其他模块需要的绑定暴露出来,将那些会污染顶层命名空间和有可能导致无意识的使用和重定义 86 | 的绑定隐藏起来.一个常见的模块构建如下 87 | 88 | 89 | (define export-var #f) 90 | (let () 91 | (define var expr) 92 | ... 93 | 内部表达式 94 | ... 95 | (set! export-var export-val)) 96 | 97 | 首先定义一个顶层的值,这个值是之后需要暴露出去的 98 | 然后是一个模块的内部定义 99 | 最后使用set!将正确的值赋值给需要暴露的值 100 | 101 | 这种形式的模块化的一个优点就是let表达式中间的函数体可以被当做是被注释掉的,这使得测试比较容易,但是这也会带来一些缺点 102 | 103 | |# 104 | 105 | (define calc #f) 106 | (let () 107 | (define do-calc 108 | (lambda (ek expr) 109 | (cond 110 | [(number? expr) expr] 111 | [(and (list? expr) (= (length expr) 3)) 112 | (let ([op (car expr)] [args (cdr expr)]) 113 | (case op 114 | [(add) (apply-op ek + args)] 115 | [(sub) (apply-op ek - args)] 116 | [(mul) (apply-op ek * args)] 117 | [(div) (apply-op ek / args)] 118 | [else (complain ek "invalid operator" op)]))] 119 | [else (complain ek "invalid expression" expr)]))) 120 | (define apply-op 121 | (lambda (ek op args) 122 | (op (do-calc ek (car args)) (do-calc ek (cadr args))))) 123 | (define complain 124 | (lambda (ek msg expr) 125 | (ek (list msg expr)))) 126 | (set! calc 127 | (lambda (expr) 128 | ; grab an error continuation ek 129 | (call/cc 130 | (lambda (ek) 131 | (do-calc ek expr)))))) 132 | 133 | (calc '(add (mul 3 2 ) -4)) 134 | (calc '(add (mul 3 2) (div 4))) 135 | -------------------------------------------------------------------------------- /TSPL/3.6.1.ss: -------------------------------------------------------------------------------- 1 | ;;修改gpa 使其可以处理x成绩,x不计入成绩 2 | (library (grades) 3 | (export gpa->grade gpa) 4 | (import (rnrs)) 5 | 6 | (define in-range? 7 | (lambda (x n y) 8 | (and (>= n x) (< n y)))) 9 | 10 | (define-syntax range-case 11 | (syntax-rules (- else) 12 | [(_ expr ((x - y) e1 e2 ...) ... [else ee1 ee2 ...]) 13 | (let ([tmp expr]) 14 | (cond 15 | [(in-range? x tmp y) e1 e2 ...] 16 | ... 17 | [else ee1 ee2 ...]))] 18 | [(_ expr ((x - y) e1 e2 ...) ...) 19 | (let ([tmp expr]) 20 | (cond 21 | [(in-range? x tmp y) e1 e2 ...] 22 | ...))])) 23 | 24 | (define letter->number 25 | (lambda (x) 26 | (case x 27 | [(a) 4.0] 28 | [(b) 3.0] 29 | [(c) 2.0] 30 | [(d) 1.0] 31 | [(f) 0.0] 32 | [else (assertion-violation 'grade "invalid letter grade" x)]))) 33 | 34 | (define gpa->grade 35 | (lambda (x) 36 | (range-case x 37 | [(0.0 - 0.5) 'f] 38 | [(0.5 - 1.5) 'd] 39 | [(1.5 - 2.5) 'c] 40 | [(2.5 - 3.5) 'b] 41 | [else 'a]))) 42 | 43 | (define-syntax gpa 44 | (syntax-rules () 45 | [(_ g1 g2 ...) 46 | (letrec ([f (lambda (l) (cond 47 | [(null? l) '()] 48 | [(eqv? 'x (car l)) (f (cdr l))] 49 | [else (cons (letter->number (car l)) (f (cdr l)))]))]) 50 | (let ([ls (f '(g1 g2 ...))]) 51 | (if (= (length ls) 0) 52 | 0 53 | (/ (apply + ls) (length ls)))))])) 54 | ) 55 | -------------------------------------------------------------------------------- /TSPL/3.6.2.ss: -------------------------------------------------------------------------------- 1 | ;;编写distribution函数 2 | ;; (distribution a b a c c c a f b a) ((4 a) (2 b) (3 c) (0 d) (1 f)) 3 | 4 | (library (grades) 5 | (export gpa->grade gpa distribution) 6 | (import (rnrs)) 7 | 8 | (define in-range? 9 | (lambda (x n y) 10 | (and (>= n x) (< n y)))) 11 | 12 | (define-syntax range-case 13 | (syntax-rules (- else) 14 | [(_ expr ((x - y) e1 e2 ...) ... [else ee1 ee2 ...]) 15 | (let ([tmp expr]) 16 | (cond 17 | [(in-range? x tmp y) e1 e2 ...] 18 | ... 19 | [else ee1 ee2 ...]))] 20 | [(_ expr ((x - y) e1 e2 ...) ...) 21 | (let ([tmp expr]) 22 | (cond 23 | [(in-range? x tmp y) e1 e2 ...] 24 | ...))])) 25 | 26 | (define letter->number 27 | (lambda (x) 28 | (case x 29 | [(a) 4.0] 30 | [(b) 3.0] 31 | [(c) 2.0] 32 | [(d) 1.0] 33 | [(f) 0.0] 34 | [else (assertion-violation 'grade "invalid letter grade" x)]))) 35 | 36 | (define gpa->grade 37 | (lambda (x) 38 | (range-case x 39 | [(0.0 - 0.5) 'f] 40 | [(0.5 - 1.5) 'd] 41 | [(1.5 - 2.5) 'c] 42 | [(2.5 - 3.5) 'b] 43 | [else 'a]))) 44 | 45 | (define-syntax gpa 46 | (syntax-rules () 47 | [(_ g1 g2 ...) 48 | (letrec ([f (lambda (l) (cond 49 | [(null? l) '()] 50 | [(eqv? 'x (car l)) (f (cdr l))] 51 | [else (cons (letter->number (car l)) (f (cdr l)))]))]) 52 | (let ([ls (f '(g1 g2 ...))]) 53 | (if (= (length ls) 0) 54 | 0 55 | (/ (apply + ls) (length ls)))))])) 56 | (define $distribution 57 | (lambda (ls) 58 | (let loop ([ls ls] [a 0] [b 0] [c 0] [d 0] [f 0]) 59 | (if (null? ls) 60 | (list (list a 'a) (list b 'b) (list c 'c) 61 | (list d 'd) (list f 'f)) 62 | (case (car ls) 63 | [(a) (loop (cdr ls) (+ a 1) b c d f)] 64 | [(b) (loop (cdr ls) a (+ b 1) c d f)] 65 | [(c) (loop (cdr ls) a b (+ c 1) d f)] 66 | [(d) (loop (cdr ls) a b c (+ d 1) f)] 67 | [(f) (loop (cdr ls) a b c d (+ f 1))] 68 | ; ignore x grades, per preceding exercise 69 | [(x) (loop (cdr ls) a b c d f)] 70 | [else (assertion-violation 'distribution 71 | "unrecognized grade letter" 72 | (car ls))]))))) 73 | (define-syntax distribution 74 | (syntax-rules () 75 | [(_ g1 g2 ...) 76 | ($distribution '(g1 g2 ...))])) 77 | 78 | ) 79 | -------------------------------------------------------------------------------- /TSPL/3.6.3.ss: -------------------------------------------------------------------------------- 1 | (library (grades) 2 | (export gpa->grade gpa distribution histogram) 3 | (import (rnrs)) 4 | 5 | (define in-range? 6 | (lambda (x n y) 7 | (and (>= n x) (< n y)))) 8 | 9 | (define-syntax range-case 10 | (syntax-rules (- else) 11 | [(_ expr ((x - y) e1 e2 ...) ... [else ee1 ee2 ...]) 12 | (let ([tmp expr]) 13 | (cond 14 | [(in-range? x tmp y) e1 e2 ...] 15 | ... 16 | [else ee1 ee2 ...]))] 17 | [(_ expr ((x - y) e1 e2 ...) ...) 18 | (let ([tmp expr]) 19 | (cond 20 | [(in-range? x tmp y) e1 e2 ...] 21 | ...))])) 22 | 23 | (define letter->number 24 | (lambda (x) 25 | (case x 26 | [(a) 4.0] 27 | [(b) 3.0] 28 | [(c) 2.0] 29 | [(d) 1.0] 30 | [(f) 0.0] 31 | [else (assertion-violation 'grade "invalid letter grade" x)]))) 32 | 33 | (define gpa->grade 34 | (lambda (x) 35 | (range-case x 36 | [(0.0 - 0.5) 'f] 37 | [(0.5 - 1.5) 'd] 38 | [(1.5 - 2.5) 'c] 39 | [(2.5 - 3.5) 'b] 40 | [else 'a]))) 41 | 42 | (define-syntax gpa 43 | (syntax-rules () 44 | [(_ g1 g2 ...) 45 | (letrec ([f (lambda (l) (cond 46 | [(null? l) '()] 47 | [(eqv? 'x (car l)) (f (cdr l))] 48 | [else (cons (letter->number (car l)) (f (cdr l)))]))]) 49 | (let ([ls (f '(g1 g2 ...))]) 50 | (if (= (length ls) 0) 51 | 0 52 | (/ (apply + ls) (length ls)))))])) 53 | (define $distribution 54 | (lambda (ls) 55 | (let loop ([ls ls] [a 0] [b 0] [c 0] [d 0] [f 0]) 56 | (if (null? ls) 57 | (list (list a 'a) (list b 'b) (list c 'c) 58 | (list d 'd) (list f 'f)) 59 | (case (car ls) 60 | [(a) (loop (cdr ls) (+ a 1) b c d f)] 61 | [(b) (loop (cdr ls) a (+ b 1) c d f)] 62 | [(c) (loop (cdr ls) a b (+ c 1) d f)] 63 | [(d) (loop (cdr ls) a b c (+ d 1) f)] 64 | [(f) (loop (cdr ls) a b c d (+ f 1))] 65 | ; ignore x grades, per preceding exercise 66 | [(x) (loop (cdr ls) a b c d f)] 67 | [else (assertion-violation 'distribution 68 | "unrecognized grade letter" 69 | (car ls))]))))) 70 | (define-syntax distribution 71 | (syntax-rules () 72 | [(_ g1 g2 ...) 73 | ($distribution '(g1 g2 ...))])) 74 | (define histogram 75 | (lambda (port distr) 76 | (for-each 77 | (lambda (n g) 78 | (put-datum port g) 79 | (put-string port ": ") 80 | (let loop ([n n]) 81 | (unless (= n 0) 82 | (put-char port #\*) 83 | (loop (- n 1)))) 84 | (put-string port "\n")) 85 | (map car distr) 86 | (map cadr distr)))) 87 | 88 | ) 89 | -------------------------------------------------------------------------------- /TSPL/3.6.ss: -------------------------------------------------------------------------------- 1 | #| 2 | 3 | 之前的章节,我们讨论了一个模块化的方式: 4 | 但是这种形式有几个缺点 5 | 6 | - 没有可移植性,scheme的标准不保证顶层变量的行为甚至存在 7 | - 需要赋值,这会使得代码显得有些尴尬和有可能使得编译器的分析和优化更难 8 | - 不支持关键词绑定的发布,应为没有类似set!的关键词 9 | 10 | 使用libraries是避免这种问题的一个可选方案, 11 | 一个libraries会暴露出一些标识符,每个都由libraries定义 12 | 或者从其他libraries中导入,一个暴露的标识符不能被绑定为一个变量,可能是一个关键词 13 | 14 | 以下的代码库导出两个标识符 gpa->grade以及关键词 gpa. 变量gpa->grade 绑定在一个接收GPA的过程上,GPA是一个数字.这个过程返回对应的基于四分制的字母等级,abcd. 15 | 关键词gpa表示一个语法扩展 16 | 17 | |# 18 | (library (grades) 19 | (export gpa->grade gpa) 20 | (import (rnrs)) 21 | 22 | (define in-range? 23 | (lambda (x n y) 24 | (and (>= n x) (< n y)))) 25 | 26 | (define-syntax range-case 27 | (syntax-rules (- else) 28 | [(_ expr ((x - y) e1 e2 ...) ... [else ee1 ee2 ...]) 29 | (let ([tmp expr]) 30 | (cond 31 | [(in-range? x tmp y) e1 e2 ...] 32 | ... 33 | [else ee1 ee2 ...]))] 34 | [(_ expr ((x - y) e1 e2 ...) ...) 35 | (let ([tmp expr]) 36 | (cond 37 | [(in-range? x tmp y) e1 e2 ...] 38 | ...))])) 39 | 40 | (define letter->number 41 | (lambda (x) 42 | (case x 43 | [(a) 4.0] 44 | [(b) 3.0] 45 | [(c) 2.0] 46 | [(d) 1.0] 47 | [(f) 0.0] 48 | [else (assertion-violation 'grade "invalid letter grade" x)]))) 49 | 50 | (define gpa->grade 51 | (lambda (x) 52 | (range-case x 53 | [(0.0 - 0.5) 'f] 54 | [(0.5 - 1.5) 'd] 55 | [(1.5 - 2.5) 'c] 56 | [(2.5 - 3.5) 'b] 57 | [else 'a]))) 58 | 59 | (define-syntax gpa 60 | (syntax-rules () 61 | [(_ g1 g2 ...) 62 | (let ([ls (map letter->number '(g1 g2 ...))]) 63 | (/ (apply + ls) (length ls)))])) 64 | ) 65 | -------------------------------------------------------------------------------- /TSPL/4.1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | #| 3 | 过程以及变量绑定是构建scheme程序的时候最基本的东西。这章主要描述了创建过程和多变量绑定的一小部分语法 4 | 形式。一开始是最基本的值引用和lambda 表达式，然后是变量绑定和赋值，例如define ，letrec，letvalue，set！ 5 | 其他的绑定和赋值形式不会是主要的，例如命名的let 6 | |# 7 | 8 | 9 | #| 10 | 任何在程序中出现的有可见变量绑定的标识符都是变量。 11 | 例如，在define，lambda，let或者其他的变量绑定方式中所定义的标识符 12 | |# 13 | 14 | list 15 | (define x 'a) 16 | (list x x) 17 | (let ([x 'b]) 18 | (list x x)) 19 | (let ([let 'let]) let) 20 | 21 | #| 22 | 在顶层程序或者库代码中出现未绑定到变量，关键词，记录名或者其他实体的标识符都是不符合语法规则的。 23 | 因为library，顶层程序和lambda或者其他局部主体中的定义的作用域是整个主体，所以不一定要先定义变量 24 | 然后才能引用，只要该变量在定义结束时没有真正解析就好了。 25 | |# 26 | 27 | ;; (define f 28 | ;; (lambda (x) 29 | ;; (g x))) 30 | ;; (define g 31 | ;; (lambda (x) 32 | ;; (+ x x))) 33 | 34 | #|这是可以的，在定义g之前引用了g|# 35 | 36 | ;; (define q (g 3)) 37 | ;; (define g 38 | ;; (lambda (x) 39 | ;; (+ x x))) 40 | ;;由于定义q的时候需要解析g所以这会报错 41 | -------------------------------------------------------------------------------- /TSPL/4.2.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;; lambda 4 | 5 | 6 | #| 7 | 语法：(lambda formals body1 body2 ...) 8 | 9 | lambda 用来创建过程。任何创建过程和局部变量绑定的操作最终都是由lambda或case-lambda来实现的 10 | 11 | formals是指形参，body1 body2 。。 是lambda 的主体 12 | 13 | 主体可能还包含一系列的定义，在这时这些定义的定义域是局部的 14 | 如果定义存在，那么在扩展（解析？）lambda主体的时候关键词绑定会被使用和丢弃，lambda 的主体会根据定义和剩下的bodys被转换成letrec* 表达式，以下的讨论都建立在这个转换已经做好了的基础上 15 | 16 | 当一个过程被创建后，所有的变量绑定都会保留在函数体重，除了形参。当这个过程被应用与真正的参数上时，形参 17 | 才真正绑定在真正的参数上。保留下来的环境也被恢复，函数体被解析了（eval） 18 | 19 | 一旦被应用之后，形参之中的参数将会如下形式定义 20 | 21 | - 如果formals是一个变量的列表，比如 （x y z）,如果给出的实际变量的数量和形参定义一致那么，形参和实参一一绑定，否则会报错说参数个数不匹配 22 | 23 | - 如果参数是单个变量，比如x，那么x绑定的是一个实参的列表 24 | 25 | - 如果参数的形式如 （x y . z）,在点之前的参数会一一绑定在实参是而最后的一个变量会绑定剩下的实参的列表 26 | 27 | 28 | 当lambda 的函数主体被解析的时候，函数体中的表达式会挨个被解析（eval）。lambda表达式的返回值是最后一个表达式的返回值。 29 | 30 | 31 | 过程在被打印的时候不一定有统一的形式，不同的scheme解释器有不同的做法，本书中使用# 来表示过程 32 | 33 | |# 34 | 35 | (lambda (x) (+ x 3)) 36 | ((lambda (x) (+ x 7)) 7) 37 | 38 | ((lambda (x . y) (list x y)) 28 37) 39 | 40 | 41 | ((lambda x x) 7 13) 42 | 43 | -------------------------------------------------------------------------------- /TSPL/4.3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | scheme 的lambda 总是返回一个过程要么接收固定数量的参数，要么接收大于等于某一个数量的参数 5 | 6 | (lambda (var1 ... var n) b1 b2) 7 | 接收n个参数 8 | 9 | （lambda r b1 b2) 10 | 接收任意个参数，0到无限 11 | 12 | （lambda (var1 .., varn . r) body1 body2 ) 13 | 接收大于等于n个参数 14 | 15 | 16 | lambda 并不能直接产生一个过程，接收两个或者三个参数。 17 | 更加确切地说lambda不支持可选参数。 18 | 可选参数可以通过lambda，长度判断虽然可能显得不那么明显和有效率 19 | 20 | case-lambda语法可以直接支持可选参数，同时也支持固定或无限参数。 21 | case-lambda 基于A New Approach to Procedures with Variable Arity 中提到的lambda× 语法 22 | 23 | 24 | case-lambda 表达式由一系列clause组成，每一个都相当于一个lambda表达式，每个clause都以以一下形式组成 25 | [formals body1 body2 ...] 26 | 27 | 每一个clause的语法都和lambda一样 28 | case-lambda 表达式产生的过程可以接收的参数的个数，由每个clause能接收的参数共同决定 29 | 30 | 当一个由lambda-case创建的过程被执行的时候，clause会被挨个查看，并执行第一个能够接收实参的clause 31 | ，形参就会和对应的实参绑定，然后执行body1 body2 ... 32 | 每个clause 的参数定义和lambda类似合一接收固定参数，也可以是无限参数，又或者是大于等于n个参数 33 | 如果lambda-case所定义的过程接收到的参数在所有的clause都无法匹配则会产生&assertion报错 34 | 35 | 以下过程make-list通过case-lambda 支持可选的填充参数 36 | 37 | |# 38 | 39 | 40 | (define make-list 41 | (case-lambda 42 | [(n) (make-list n #f)] 43 | [(n x) 44 | (do ([n n (- n 1)] [ls '() (cons x ls)]) 45 | ((zero? n) ls))])) 46 | #| 47 | substring 过程可以通过case-lambda进行扩展，可以支持默认的start，end参数 48 | 只提供一个start参数则默认end是字符串结尾 49 | 没有start 和end则相当于string-copy 50 | |# 51 | 52 | (define substring1 53 | (case-lambda 54 | [(s) (substring1 s 0 (string-length s))] 55 | [(s start) (substring1 s start (string-length s))] 56 | [(s start end) (substring s start end)])) 57 | 58 | 59 | ;;当只有一个参数提供时也可以将其视为结束参数，而提供和一个默认的开始 60 | 61 | (define substring2 62 | (case-lambda 63 | [(s) (substring2 s 0 (string-length s))] 64 | [(s end) (substring2 s 0 end)] 65 | [(s start end) (substring s start end)])) 66 | 67 | ;; 也可以直接去掉中间的clause只支持全部提供start end和都不提供的情况 68 | 69 | (define substring3 70 | (case-lambda 71 | [(s) (substring3 s 0 (string-length s))] 72 | [(s start end) (substring s start end)])) 73 | 74 | 75 | -------------------------------------------------------------------------------- /TSPL/4.4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;局部绑定 4 | 5 | #| 6 | 语法：(let ((var expr) ...) body1 body2 ...) 7 | 返回最后一个body的值 8 | |# 9 | 10 | 11 | #| 12 | let建立起局部变量的绑定，每一个var都绑定到对应的expr上。 13 | 绑定的变量可以在let的主体里面eval，类似于lambda 14 | 15 | let,let*,letrec以及letrec* 非常相似但是有一些略微的区别。 16 | let 表达式中的expr不在var的作用范围内。 17 | let* 以及letrec* ,对于expr的解析顺序不固定,有可能从左向右也有可能从右向左或者任何实现所倾向的顺序 18 | 使用let的时候var都是独立的,解析的顺序不重要 19 | |# 20 | 21 | (let ([x (* 3.0 3.0)] [y (* 4.0 4.0)]) 22 | (sqrt (+ x y))) 23 | 24 | (let ([x 'a] [y '(b c)]) 25 | (cons x y)) 26 | 27 | (let ([x 0] [y 1]) 28 | (let ([x y] [y x]) 29 | (list x y))) 30 | 31 | #| 32 | let 可以从lambda定义 33 | |# 34 | ;;以下是一种let的定义方式 35 | 36 | #| 37 | (define-syntax let 38 | (syntax-rules () 39 | [(_ ((x e) ...) b1 b2 ...) 40 | ((lambda (x ...) b1 b2 ...) e ...)])) 41 | |# 42 | 43 | ;;let还可以有命名的 44 | 45 | 46 | ;; 语法:(let* ((var expr) ...) body1 body2) 47 | ;; 返回 body的最后一个表达式 48 | 49 | #| 50 | let* 和let比较相似,除了expr是从左向右并且expr在剩下的作用域中有效 51 | 使用let* 时注意他是线性依赖并且解析的顺序是很重要的 52 | 53 | |# 54 | 55 | (let* ([x (* 5.0 5.0)] 56 | [y (- x (* 4.0 4.0))]) 57 | (sqrt y)) 58 | 59 | (let ([x 0] [y 1]) 60 | (let* ([x y] [y x]) 61 | (list x y))) 62 | 63 | #| 64 | 任何 let* 都可以都可以转化为一系列嵌套的let. 以下定义定义了典型的转换 65 | 66 | (define-syntax let* 67 | (syntax-rules () 68 | [(_ () e1 e2 ...) 69 | (let () e1 e2 ...)] 70 | [(_ ((x1 v1) (x2 v2) ...) e1 e2 ...) 71 | (let ((x1 v1)) 72 | (let* ((x2 v2) ...) e1 e2 ...))])) 73 | 74 | |# 75 | 76 | 77 | ;; 语法:(letrec ((var expr) ...) body1 body2 ...) 78 | ;; 返回最后的表达式的值 79 | 80 | #| 81 | letrec 和let以及let* ,除了所有的表达式expr作用域都包括在var 82 | letrec 允许定义的相互递归调用 83 | 84 | |# 85 | 86 | (letrec ([sum (lambda (x) 87 | (if (zero? x) 88 | 0 89 | (+ x (sum (- x 1)))))]) 90 | (sum 5)) 91 | 92 | #| 93 | expr 表达式解析的顺序不是固定的,所以程序一定不能在所有的表达式被解析前引用任何由letrec绑定的变量 94 | 在lambda出现的变量都不被记为引用,, unless the resulting procedure is applied before all of the values have been computed. 95 | 如果违反此限制，则会引发具有条件类型和断言的异常。 96 | 97 | 一个expr不能有超过一次的返回.也就是说,他不能同时有正常的返回和调用延续获得返回 98 | 并且不应该通过调用这样的延续来返回两次。scheme的实现并不要求检查这种违反限制的使用， 99 | 但是如果用户这么做了就会得到一个异常 100 | 101 | 选择使用 letrec而不是let*或let当你需要变量的定义有循环依赖并且解析的顺序是不中要的时候 102 | 103 | 104 | letrec表达式的形式可以通过let和set!来做到 105 | 106 | |# 107 | 108 | ;; (let ((var #f) ...) 109 | ;; (let ((temp expr) ...) 110 | ;; (set! var temp) ... 111 | ;; (let () body1 body2 ...))) 112 | 113 | 114 | #| 115 | 在这里 temp是新的没有在letrec中出现的变量,每一个temp对应一个(temp expr). 116 | 最外面的let先建立起值绑定,绑定的初始值并不重要,所以在这里使用了#f.绑定已经出现了,所以expr中可以 117 | 出现这些变量的引用.所以这些expr的解析环境包含这些变量.中间层的let会解析这些表达式并且绑定到临时变量上 118 | ,set!将表达式再绑定到对应的变量上。最内层的let就是letrec内部的函数体 119 | 120 | 这种转换并不强制和限制expr中的解析和赋值。如果做出这种严格限制我们也可以生成更加高效的代码 121 | |# 122 | 123 | -------------------------------------------------------------------------------- /TSPL/4.5.ss: -------------------------------------------------------------------------------- 1 | (import (scheme)) 2 | ;; 语法：(let-values ((formals expr) ..) body1 body2 ...) 3 | ;; 语法：(let*-values ((formals expr) ...) body1 body2 ...) 4 | 5 | ;;返回最后一个表达式的值 6 | 7 | #| 8 | let-values 是一个方便的方式将多个值绑定到变量上。let-values的结构和let类似，但是接受任意参数 9 | 就像lambda一样。 10 | let*-values 的作用类似，但是从左向右的顺序绑定，就像let* 。 11 | 就像lambda所做的一样，如果形参和实参的数量不匹配那么就会引发异常 12 | 13 | |# 14 | 15 | (let-values ([(a b) (values 1 2)] [c (values 1 2 3)]) 16 | (list a b c)) 17 | 18 | (let*-values ([(a b) (values 1 2)] [(a b) (values b a)]) 19 | (list a b)) 20 | -------------------------------------------------------------------------------- /TSPL/4.6.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;定义变量 4 | ;;变量是不确切的翻译,实际上不像变量一样可以随意赋值.需要使用set! 5 | 6 | #| 7 | syntax: (define var expr) 8 | syntax: (define var) 9 | syntax: (define (var0 var1 ...) body1 body2 ...) 10 | syntax: (define (var0 . varr) body1 body2 ...) 11 | syntax: (define (var0 var1 var2 ... . varr) body1 body2 ...) 12 | 13 | 第一种形式,define将expr 的值绑定到var上.expr不应该有多次返回.不应同时通过普通和延续返回值,也不可以通过两次调用返回.scheme实现不需要检查这一限制,但是如果用户这么做了,将会条件类型&assertion的异常. 14 | 15 | 第二种形式和(define var unspecified)等价,此处unspecified是一些不确定的值. 16 | 剩下的形式都是将var绑定到对应参数和函数体的过程上,语法规则与lambda类似 17 | 18 | (define var 19 | (lambda formals 20 | body1 body2 ...)) 21 | 22 | var 就是var0 formals 等价与 var1 var2 var3 .... 23 | 24 | 25 | 定义有可能出现在库的实现中,出现在顶层程序中,也有可能出现在lambda和case-lambda的函数体前.或者任何 26 | 可以从lambda推导出来的形式比如let* ,letrec*. 在函数体中出现的任何定义都会在宏展开的时候转换为letrec* 27 | 28 | 语法定义有可能出现在任何变量定义有出现的地方。 29 | |# 30 | 31 | ;; (define x 3) 32 | ;; (define f (lambda (x y) 33 | ;; (* (+ x y) 2))) 34 | ;; (f 5 4) 35 | ;; (define (sum-of-squares x y) 36 | ;; (+ (* x x) (* y y))) 37 | ;; (sum-of-squares 3 4) 38 | 39 | 40 | ;; (define f 41 | ;; (lambda (x) 42 | ;; (+ x 1))) 43 | ;; (let ([x 2]) 44 | ;; (define f 45 | ;; (lambda (y) 46 | ;; (+ y x))) 47 | ;; (f 3)) 48 | 49 | ;; (f 3) 50 | 51 | #| 52 | 一些列的定义可以通过begin表达式包裹起来。以这种形式将定义打包可以出现在任何一般的变量以及语法定义可能出现的地方。这些定义将会被当做分开的，就是说像是没有用begin包裹起来一样。这项特性可以让语法扩展展开成一系列的定义 53 | |# 54 | 55 | (define-syntax multi-define-syntax 56 | (syntax-rules () 57 | [(_ (var expr) ...) 58 | (begin 59 | (define-syntax var expr) 60 | ...)])) 61 | 62 | (let () 63 | (define plus 64 | (lambda (x y) 65 | (if (zero? x) 66 | y 67 | (plus (sub1 x) (add1 y))))) 68 | (multi-define-syntax 69 | (add1 (syntax-rules () [(_ e) (+ e 1)])) 70 | (sub1 (syntax-rules () [(_ e) (- e 1)]))) 71 | (plus 7 8)) 72 | 73 | 74 | ;;很多scheme的repl中合一交互式地输入变量或者定义，又或者从文件载入变量和定义。 75 | #| 76 | 这些顶层定义的行为解释不包括在r6rs中，但是在大多是的实现中，只要顶层变量在引用或者赋值前存在就可以。 77 | 例如在顶层定义f中使用了g，但是g还没有被定义。大多数实现会假定g是之后会被定义的变量。 78 | 79 | (define f 80 | (lambda (x) 81 | (g x))) 82 | 如果在f被调用解析之前g被定义了，如果g是一个变量，那么之前的假设就会成立，对于f的调用就会如期执行。 83 | 84 | 但是如果g被定义为一个语法扩展的关键词，g将会是一个变量的假设就被证明是错误的，如果f在被调用前没有被重新定义，那么scheme的实现会抛出一个异常。 85 | 86 | |# 87 | 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /TSPL/4.7.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;赋值 4 | ;;语法：(set! var expr) 5 | 6 | #| 7 | set！不会建立一个新的绑定而是改变一个已有的绑定。首先会解析expr的值，然后将其绑定在var上。任何对于 8 | var接下来的引用就会指向新的值了 9 | 10 | 赋值在scheme中不像其他语言中那样被频繁使用，但是赋值在实现状态改变的时候非常有用。 11 | |# 12 | 13 | (define flip-flop 14 | (let ([start #f]) 15 | (lambda () 16 | (set! start (not start)) 17 | start))) 18 | 19 | (flip-flop) 20 | (flip-flop) 21 | (flip-flop) 22 | (flip-flop) 23 | 24 | #| 25 | 赋值对于缓存也很有用。 26 | 下面的这个例子使用了叫做记忆化的技术 27 | 这会将上一次计算的返回值保存起来这样就不用重复计算了。 28 | |# 29 | (define memoize 30 | (lambda (proc) 31 | (let ([cache '()]) 32 | (lambda (x) 33 | (cond 34 | [(assq x cache) => cdr] 35 | [else 36 | (let ([ans (proc x)]) 37 | (set! cache (cons (cons x ans) cache)) 38 | ans)]))))) 39 | 40 | (define fibonacci 41 | (memoize 42 | (lambda (n) 43 | (if (< n 2) 44 | 1 45 | (+ (fibonacci (- n 1)) (fibonacci (- n 2))))))) 46 | 47 | (fibonacci 100) 48 | 49 | -------------------------------------------------------------------------------- /TSPL/5.1.rkt: -------------------------------------------------------------------------------- 1 | ;; 控制语句 2 | #lang racket 3 | 4 | 5 | #| 6 | 这章会介绍scheme的控制结构的语法以及过程。第一节会介绍最基本的控制结构，过程应用，剩下的章节 7 | 会介绍squencing，条件解析，递归，mapping，延续，延迟求值，多值，解析在运行时刻构建的程序 8 | 9 | |# 10 | 11 | #| 12 | 过程的应用 13 | 14 | 语法: (expr0 expr1 ...) 15 | 返回：将expr0 应用于其后参数的返回值 16 | 17 | 一个过程的应用是scheme程序中最基本的结构。任何不以语法关键词开头的表达式中，第一个位置应该是一个过程。表达式expr0，expr1 。。。 会被解析；每个表达式解析后都会得到一个值。然后expr0的值就会被应用在expr1 ... 上。如果expr0解析后不是一个过程那么就会抛出异常。 18 | 19 | 过程和参数的解析顺序不是固定的，从左向右，从右向左或者任意的顺序。解析的顺序是确保依次的，无关顺序，解析时一定是先完全解析一个，然后才是下一个 20 | 21 | |# 22 | 23 | (+ 3 4) 24 | 25 | ((if (odd? 3) + -) 6 2) 26 | 27 | ((lambda (x) x) 5) 28 | 29 | (let ([f (lambda (x) (+ x x))]) 30 | (f 8)) 31 | 32 | 33 | #| 34 | （apply procedure obj ... list） 35 | 返回将 procedure应用与obj... 和元素list的结果 36 | 37 | 38 | apply 会调用 procedure ，将第一个obj作为procedure 的第一个参数，第二个obj作为第二个参数，以此类推。将list中剩下的元素当做是剩下的参数。因此 procedure所有的参数就是objs加上list中的元素。 39 | apply对于参数是以list呈现的时候会非常有用，这样程序员就不用解构一个list来得到参数了。 40 | |# 41 | 42 | (apply + '(4 5)) 43 | 44 | (apply min '(6 8 3 2 5)) 45 | 46 | (apply min 1 2 3 4 '( 564 21 1 0 -1) ) 47 | 48 | (apply vector 'ab 'b '(c d e f)) 49 | 50 | (apply append '(1 2 3) '((a b ) (c d e) (f))) 51 | 52 | 53 | -------------------------------------------------------------------------------- /TSPL/5.2.ss: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | #| 4 | 序列 5 | 6 | 语法：（begin expr1 expr2 ...） 7 | 返回： 最后一个表达式的值 8 | 9 | 表达式expr1 expr2 。。。 会被依次解析。begin可以用来依次赋值，io或者其他需要产生副作用的操作 10 | |# 11 | 12 | (define x 3) 13 | (begin 14 | (set! x (+ x 1)) 15 | (+ x x)) 16 | 17 | #| 18 | 一个begin有可能包含0或更多的定义，所以可以出现在定义可以出现的地方。 19 | |# 20 | 21 | (let () 22 | (begin (define x 3) (define y 4)) 23 | (+ x y)) 24 | 25 | #|这种形式的begin会被首先转换为多值定义|# 26 | 27 | #| 28 | 例如lambda, case-lambda, let, let*, letrec, and letrec*,的函数体，以及cond，case，do的结果部分 29 | 都可以被当做有一个隐式的begin ，依次执行表达式并且返回最后一个表达式的值。 30 | |# 31 | 32 | (define swap-pair! 33 | (lambda (x) 34 | (let ([temp (car x)]) 35 | (set-car! x (cdr x)) 36 | (set-cdr! x temp) 37 | x))) 38 | (swap-pair! (cons 'a 'b)) 39 | 40 | 41 | 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /TSPL/5.4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;语法：(let name ((var expr) ...) body1 body2 ...) 4 | 5 | #| 6 | 这种形式的let叫做命名的let(named let),是一种常用的的递归和迭代构造 7 | 这和更加常见的；let很类似，将expr ... 绑定到var ...上。这些变量的作用域是body1 body2 。。。 8 | 就像lambda那样。 9 | 此外变量名 name 在函数体中也可以用，所以可以递归或者迭代地调用，参数会变成var。。。的新绑定值 10 | |# 11 | 12 | ;; 命名的let可以用letrec重写 13 | 14 | ;; ((letrec (name (lambda (var ...) body1 body2 ...)) 15 | ;; name) 16 | ;; expr ...) 17 | 18 | 19 | 20 | (define divisors 21 | (lambda (n) 22 | (let f ([i 2]) 23 | (cond 24 | [(>= i n) '()] 25 | [(integer? (/ n i)) (cons i (f (+ i 1)))] 26 | [else (f (+ i 1))])))) 27 | 28 | (divisors 1000) 29 | 30 | ;;以下是尾递归优化的版本。 31 | 32 | ;; (define divisors 33 | ;; (lambda (n) 34 | ;; (let f ([i 2] [ls '()]) 35 | ;; (cond 36 | ;; [(>= i n) ls] 37 | ;; [(integer? (/ n i)) (f (+ i 1) (cons i ls))] 38 | ;; [else (f (+ i 1) ls)])))) 39 | 40 | 41 | ;;语法：(do ((var init update) ...) (test result ...) expr ...) 42 | ;;返回最后一个result的值 43 | 44 | #| 45 | do 可以让有所限制的迭代更容易表述。变量var ...一开始被绑定为init... 在其后的迭代中被绑定到update上。 46 | test，update ...,expr ...,以及 result ... 都在var ... 的语法作用域范围内。 47 | 每一次迭代中 test都会被解析，如果返回值是true，迭代结束，result 。。。表达式依次执行，并且最后一个表达式的值被返回。如果result是空的那么do的返回值不确定。 48 | 如果test的值是false，表达式expr。。。 依次执行，update执行，新的值被绑定到var，迭代继续。 49 | 50 | expr通常只为了产生副作用才存在，通常使用的时候可以整个不写。任何update也可以省略， 51 | 在这种情况下和update与var对应一样。 52 | 53 | 尽管大多数语言里面的循环是用赋值来更新循环变量的，do却是通过重新绑定来更新。事实上do语句不会产生任何副作用除非其自语句有副作用。 54 | |# 55 | 56 | (define factorial 57 | (lambda (n) 58 | (do ([i n (- i 1)] 59 | [a 1 (* a i)]) 60 | ((zero? i) a)))) 61 | 62 | 63 | (define fibnacci 64 | (lambda (n) 65 | (if (= 0 n) 66 | 0 67 | (do ([i n (- i 1)] 68 | [a1 1 (+ a1 a2)] 69 | [a2 0 a1]) 70 | ((zero? i) a1))))) 71 | (fibnacci 6) 72 | 73 | 74 | (define divisors2 75 | (lambda (n) 76 | (do ([i 2 (+ i 1)] 77 | [ls '() 78 | (if (integer? (/ n i)) 79 | (cons i ls) 80 | ls)]) 81 | ((>= i n) ls)))) 82 | 83 | ;;将向量v的每一个元素乘k 84 | 85 | (define scale-vector 86 | (lambda (v k) 87 | (let ([n (vector-length v)]) 88 | (do ([i 0 (+ i 1)]) 89 | ((= i n)) 90 | (vector-set! v i (* (vector-ref v i) k)))))) 91 | 92 | (define vec (vector 1 2 3 4 5)) 93 | (scale-vector vec 2) 94 | vec 95 | -------------------------------------------------------------------------------- /TSPL/5.7.ss: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;语法形式delay和过程force通常一起使用来实现延迟计算。 3 | ;;传递给lazy的表达式在其值被需要前不会被解析，一旦被解析，不会再被二次解析。 4 | 5 | 6 | #| 7 | 语法：(delay expr) 8 | 返回：一个承诺 9 | 过程：(force promise) 10 | 返回：执行promise的结果 11 | 12 | 当一个delay产生的promise被force之后，expr就被解析出来，又“记起”剩下的结果。在此之后每当一个promise被force，他会返回记住的值而不是重新解析一遍。 13 | 14 | delay和force通常只在没有副作用的情况下使用，例如，赋值，因此解析的顺序是不一定的。 15 | 16 | 使用delay和force的好处是一些计算只有当正真需要的时候才会被执行，这可以节省大量的计算力。延迟计算可以用来实现概念上的无限的list，或者stream。以下展示了如何使用force和delay构建抽象的stream。 17 | 一个stream是一个承诺，当被froce之后，会返回一个序对，这个序对的cdr是stream 18 | 19 | |# 20 | 21 | (define stream-car 22 | (lambda (s) 23 | (car (force s)))) 24 | 25 | (define stream-cdr 26 | (lambda (s) 27 | (cdr (force s)))) 28 | 29 | (define counters 30 | (let net ([n 1]) 31 | (delay (cons n (next (+ n 1)))))) 32 | 33 | (define stream-add 34 | (lambda (s1 s2) 35 | (delay (cons (+ (stream-car s1) 36 | (stream-car s2)) 37 | (stream-add (stream-cdr s1) 38 | (stream-cdr s2)))))) 39 | 40 | 41 | ;;delay 可以如下定义 42 | (define-syntax delay 43 | (syntax-rules () 44 | [(_ expr) (make-promise (lambda () expr))])) 45 | 46 | ;;make-promise可以这样定义 47 | 48 | (define make-promise 49 | (lambda (p) 50 | (let ([val #f] [set? #f]) 51 | (lambda () 52 | (unless set? 53 | (let ([x (p)]) 54 | (unless set? 55 | (set! val x) 56 | (set! set? #t)) 57 | )) 58 | val)))) 59 | 60 | ;;有了delay的定义之后，force只是简单的调用promise就可以了 61 | (define (force promise) 62 | (promise)) 63 | 64 | 65 | ;;在make-promise中的第二次测试set？是有必要的。;;当在应用p的时候，promise是递归调用的。 66 | ;;因为一个promise必须返回相同的所以第一次应用p的结果被返回了。 67 | ;;当delay和force处理多值返回的时候是不确定的，上面的实现并没有这没做，但是下面的实现在call-with-values的帮助下实现了。 68 | 69 | 70 | (define (make-promise p) 71 | (let ([vals #f] [set? #f]) 72 | (lambda () 73 | (unless set? 74 | (call-with-values p 75 | (lambda x 76 | (unless set? 77 | (set! vals x) 78 | (set! set? #t)))) 79 | ) 80 | (apply values vals)))) 81 | 82 | (define p (delay (values 1 2 3))) 83 | 84 | (force p) 85 | 86 | (call-with-values (lambda () (force p)) +) 87 | 88 | #| 89 | 没有一个实现做得是相当正确的，因为force必须在给定的参数不是promise的时候返回异常。因为区分make-promise返回的过程和普通的过程基于现在的实现是不可能的，所以force还不能区分这两者。以下的make-promise实现和force的实现将promise作为一个promise类型的记录，这样force就可以检查其类型。 90 | |# 91 | 92 | 93 | (define-record-type promise 94 | (fields (immutable p) (mutable vals) (mutable set?)) 95 | (protocol (λ(new) (λ (p) (new p #f #f))))) 96 | 97 | (define force 98 | (λ (promise) 99 | (unless (promise? promise) 100 | (assertion-violation 'promise "invalid argument" promise) 101 | ) 102 | (unless (promise-set? promise) 103 | (call-with-values (promise-p promise) 104 | (λ x 105 | (unless (promise-set? promise) 106 | (promise-val-set! promise x) 107 | (promise-set?-set! promise #t) 108 | )))) 109 | (apply values (promise-vals promise)))) 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | -------------------------------------------------------------------------------- /TSPL/5.9.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;scheme的eval允许程序员构造和写出解析其他程序的程序,在运行时进行编程的能力不能被用的太多,但是如果需要的话还是很有用的 4 | 5 | 6 | ;;函数:(eval obj env) 7 | ;;返回:在env中解析obj 8 | 9 | ;;如果obj不符合语法规范就会报语法错误.通过environment,scheme-report-environment,以及null-environment返回的值是不可被修改的. 10 | ;;所以如果obj中的语句有修改env中的值的行为的话也会报错. 11 | 12 | (define cons 'not-cons) 13 | 14 | 15 | (eval '(let ([x 1]) (+ x 1)) (make-base-namespace)) 16 | 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /TSPL/5.9.ss: -------------------------------------------------------------------------------- 1 | (import (scheme)) 2 | 3 | (+ 1 1) 4 | (eval '(let ([x 3]) (cons x 4)) (environment '(rnrs))) 5 | 6 | 7 | ;;函数 (environment import-spec) 8 | ;;返回一个环境 9 | ;;environment返回一个由导入指定器指定的绑定组合而成的环境.每一个import-spec必须是一个代表了有效的导入指定器的s表达式 10 | 11 | (define env (environment '(rnrs) '(prefix (rnrs lists) $))) 12 | 13 | (eval '($cons* 3 4 (* 5 8)) env) 14 | 15 | ;;函数:(null-environment version) 16 | ;;函数:(scheme-report-environment version) 17 | ;;返回基本的r5rs的环境 18 | 19 | ;;version 必须是5 20 | 21 | ;;null-environment返回一个由r5rs规定的语义的一系列绑定，以及辅助关键词else,=>,...和_ 22 | ;;scheme-report-environment 返回和null-environment一样的环境除了没有被r6rs定义的load, interaction-environment, transcript-on, transcript-off, and char-ready?. 23 | 24 | ;;这些过程返回的绑定是对应的r6rs的库的。所以不是完全向后兼容的，尽管标识符没有被使用 25 | -------------------------------------------------------------------------------- /TSPL/6.1.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;操作符与对象 4 | 5 | ;;这一章节介绍了一些对象上的操作,包括了lists, numbers, characters, strings, vectors, bytevectors, symbols, booleans, hashtables, 以及 enumerations 6 | ;;第一章是常亮和引用 7 | ;;第二章是相等的判断 8 | ;;剩下的章节是介绍了 9 | 10 | ;第一章放在博客上 11 | 12 | -------------------------------------------------------------------------------- /TSPL/6.3.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;;List and pairs 3 | ;;列表和序对 4 | ;; 序对或者叫cons单元,是最基础的scheme结构类型.通过序对的cdr部分可以构建一个list,list中的元素都存在car里面cdr存放下一个序对,最后一个序对的cdr里面应该是一个空表---().如果不是那么这不是一个良构的表. 5 | 6 | ;;pairs也可以用来构建二叉树.树中的每个序对都是二叉树的内部节点,car和csdr是当前节点的子节点 7 | 8 | ;;良构的list会被包裹在括号中,以空格间隔作为一个序列打印. 9 | ;;中括号有可能被用来代替小括号,空表还是用()表示. 10 | 11 | ;;非良构的表和树有一些复杂,单个序对是以两个对象,中间加一个.的形式表示的 12 | ;;如(a . b) 。这是一个点序对的记法。 13 | ;;非良构的列表和数可以用这种点序对的方式标记,比如:(1 2 3 . 4) 或((1 . 2) . 3) 14 | ;;良构的list也可以这么表示例如: 15 | ;;(1 . (2 . (3 . ()))) 16 | 17 | 18 | ;;有可能通过set-car!,和set-cdr!创造出死循环的列表.这样的list不是良构的. 19 | 20 | ;;接收list参数的函数需要检测这是否是一个良构的list只能通过遍历的方式 21 | ;;要么遇到不合法的结尾了要么由于圈的存在死循环了. 22 | 23 | ;;例如member不需要检测list是否是非法的,这要他可以找到他要找的元素就可以了 24 | ;;list-ref也不需要检测了list中是否存在圈,因为他是通过递归来递增下标的. 25 | 26 | 27 | ;;函数(cons obj1 obj2) 28 | ;;返回一个car是obj1 cdr是obj2的序对 29 | 30 | ;;(car pair) 返回pair的car部分 31 | ;;(cdr pair) 返回pair的cdr部分 32 | ;;(set-car! pair obj) 设置pair的car为obj 33 | ;;(set-cdr! pair obj) 如上 34 | 35 | ;;caar cadr cddddr 36 | ;;c和r之间的字母分别代表了car和cdr,并且对其参数从右向左应用 37 | ;;例如cadr等价于(lambda (x) (car (cdr x))) 38 | 39 | 40 | 41 | ;;(list obj ...) 返回一个obj ...组成的列表 42 | 43 | ;;函数(cons* obj ... final-obj) 44 | ;;返回由final-obj组成的一个list(可能不是良构的) 45 | 46 | ;;(list? obj) 返回obj是否是一个良构的list 47 | 48 | ;;(length list) 返回list的element的个数 49 | ;;使用龟兔赛跑算法来计算 50 | 51 | 52 | ;;函数(list-ref list n) 53 | ;;返回返回list中的第n和值(从0开始) 54 | 55 | ;;函数(list-tail list n) 56 | ;;返回从n开始的剩下的元素。 57 | 58 | 59 | ;;函数(append) 60 | ;;函数(append list ... obj) 61 | 62 | ;;append 将第一个和第二个列表,第三个列表的...的元素组合在一起组成一个列表,除了最后一个元素之外剩下的都必须是序对构成的.最后一个元素会简单地放在列表的末尾. 63 | 64 | ;;(reverse list) 65 | ;;将一个list倒置 66 | 67 | ;;(member obj list) 68 | ;;(memq obj list) 69 | ;;(memv obj list) 70 | 71 | ;;返回第一个tail,tail的car等于obj,不然就返回#f 72 | ;;memq -- eq? 73 | ;;memv -- eqv? 74 | ;;member equal? 75 | ;;区别是比较函数不同 76 | 77 | (memq 'a '(b c a d e)) 78 | (memq 'a '(b c d e g)) 79 | (memq 'a '(a a c d f)) 80 | 81 | 82 | ;;(memf pro list) 83 | ;;chez scheme叫做memp 84 | ;;类似于member,使用pro寻找元素,pro接收一个参数 85 | 86 | 87 | ;;(remq obj list) 88 | ;;(remv obj list) 89 | ;;(remove obj list) 90 | ;;将list中出现的obj移除, 91 | ;;使用的比较函数分别是eq? eqv? equal? 92 | 93 | ;;(remf pro list)使用pro 94 | ;;使用pro来判断是否删除删除 95 | 96 | 97 | ;;(filter procedure list) 98 | ;;返回 list包含procedure返回true的部分 99 | 100 | 101 | ;;(partition pro list) 102 | ;;pro接收一个参数返回一个返回值,不能修改list 103 | ;;partition接收一个list返回两个list一个是pro返回true的list 104 | ;;另一个是pro返回false的list 105 | 106 | ;;(find pro list) 107 | ;;找到第一个pro返回true的元素 108 | 109 | 110 | ;;(assq obj alist) 111 | ;;(assv obj alist) 112 | ;;(assoc obj alist) 113 | ;;返回第一个alist中car等于obj的元素,不存在则返回#f 114 | 115 | (define (assq x ls) 116 | (cond 117 | [(null? ls) #f] 118 | [(eq? (caar ls) x) (car ls)] 119 | [else (assq x (cdr ls))])) 120 | 121 | ;;assv 和assoc和其不同之处是使用eqv? 和equal?来代替eq?作比较 122 | 123 | (assq 'b '((a . 1) (b . 2))) 124 | 125 | 126 | ;;(assp procedure alist) 127 | ;;使用procedure做判断,如果不存在则返回#f 128 | ;;a-list必须是协同列表,每个列表的元素都是(key . value)的形式 129 | 130 | (assf odd? '((1 . a) (2 . b))) 131 | 132 | 133 | ;;(list-sort predicate list) 134 | ;;根据predicate将list排序 135 | ;;predicate 应该接收两个参数,如果说以第一参数应该排在第二参数之前那就返回#t 136 | ;;predicate有可能被调用nlogn次,n为列表长度. 137 | 138 | (sort '(3 4 1 3 4 9 7 3 1 1 -1) <) 139 | 140 | 141 | -------------------------------------------------------------------------------- /TSPL/6.4.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;scheme的数字可以分为整数,有理数,实数或者复数.这是等级制的分级制度。就是说 4 | ;;复数包括实数,实数包括有理数,有理数包括整数 5 | 6 | ;;另一种划分的方式是分为精确的数字和不精确的数字.取决于函数和函数的参数. 7 | ;;可以用判断函数exact? 和inexact?来判断数字的精确性.scheme的大部分数字都是精确的 8 | ;;如果输入都是精确的数字那么返回也会是精确地.如果精确的数字和不精确的数字混合在一起,那么返回也是不精确的 9 | ;;精确的整数和有理数可以被支持到任意精度.整数的大小或者分数的分子和分母只受系统存储的限制. 10 | 11 | ;;尽管有其他的表示可能,不精确的数字忠实地使用硬件或者系统软件规定的方式表示数字. 12 | ;;复数就是使用有序队列的方式表示.实部和虚部,实部和虚部可以使精确的整数或有理数或者浮点数. 13 | 14 | ;;scheme的数字 就是直接沿用的传统的数字记号,一个精确的整数就是一连串的数字有可能在一开始还有符号位.例如,3,+19,-1000000以及1231231231231231334442312212312都表示精确的数字. 15 | 16 | ;;精确的有理数也是使用/分开的两个整数加上可选的符号位,例如3/5,-6/5,以及1/12313123123123123343958865760504.分数会被自动约分为最简形式. 17 | 18 | 19 | ;;不精确的数字使用浮点数或者科学计数法.比如1.0,-200.0是不精确的整数,1.5,0.034 20 | ;;-10e-10以及1.5e-5是不精确的有理数,2e3等于2000.0 21 | 22 | 23 | ;;一个位数的长度也许会出现在实数的最后,或者是由浮点数或者科学计数法写的复数.位数宽度w表示数字表示中的有效的位数,位数的长度默认是53,IEEE双精度浮点数的中有效位的长度.对于非规范化的IEEE双精度浮点数,尾数的宽度小于53.如果一个scheme的实现无法指定尾数的长度,他会尽可能按照要求的的长度来表示数字,不然的话会使用最大尾数宽度来表示. 24 | 25 | ;;精确和不准确的实数被写成准确或不准确的整数或有理数,但是scheme没有规定无理数的语法. 26 | 27 | ;;复数可以使用直角坐标或者极坐标系下的表示,在指教坐标系下复数表示可以写成x+yi或者x-yi,x是整数,有理数或者实数y是无符号的整数,实数或有理数.实数部分有可能被省略.例如3+4i,3.2-3/4i,+i以及-3e-5i都是以直角坐标系下表示的复数.在极坐标系中.复数用x@y的形式,x和y是整数,有理数或实数.例如1.1@1.764以及-1@-1/2是极坐标系下的复数. 28 | 29 | 30 | ;;+inf.0和-inf.0是不精确的实数表示正无穷和负无穷.+nan.0和-nan.0表示不精确的"不是一个数字"的值.无穷可以通过除以正的或负的不精确的0得到.NaN也有可能这样得到或者通过其他的方式. 31 | 32 | ;;数字的精确性可以通过前缀#e或#i来强制表示.#e将数字强制转换为精确的,#i强制数字是不精确的.例如#e1,1/1,#e1/1,#e1.0都表示精确的1,#i3/10,0.3,#i0.3表示不精确的有理数0.3 33 | 34 | ;;数字默认都是十进制的,但是可以通过前缀指定数字的进制. 35 | ;#b(二进制) 36 | ;#o(八进制) 37 | ;#d(十进制) 38 | ;#x(16进制) 39 | ;;对于16进制而言,字符a~f代表相对十进制多出来的10~15 40 | ;;例如#b10101是十进制21的二进制表示 41 | ;;#o72和十进制的58一样大 42 | ;;但是使用浮点数和科学计数法表示的数字是十进制的. 43 | 44 | 45 | 46 | ;;(exact? num) 47 | ;(inexact? num) 48 | 49 | (exact? 1) 50 | (exact? -15/16) 51 | (exact? 2.01) 52 | (exact? #i77) 53 | (exact? #i2/3) 54 | (exact? 1.0-2i) 55 | 56 | 57 | ;;(= n1 n2 ...) 58 | ;;(> n1 n2 ...) 59 | ;;(< n1 n2 ...) 60 | ;;(>= n1 n2 ...) 61 | ;;(<= n1 n2 ...) 62 | 63 | ;;常规数字比较操作 64 | ;;复数在实部和虚部全部相等的情况下是相等的.如果比较的数字包括了NaNs的话会返回#f. 65 | 66 | ;+ 67 | ;- 68 | ;* 69 | ;/ 70 | 71 | (+) 72 | (*) 73 | 74 | ;;negative? positive? 正复数 75 | ;;even? odd? 奇偶数 76 | ;;finite? infinite? 是否是有限数 77 | ;;nan? 是否是NaN, 78 | 79 | 80 | ;;(quotient int1 int2) (remainder int1 int2) 81 | ;;int1 除以int2得到的商数和余数 82 | 83 | ;;(modulo int1 int2) 取模余数; 84 | 85 | ;;remainder的到的值符号和int1相同,而modulo得到的值和int2相同 86 | 87 | ;;(div x1 x2) 88 | ;;(mod x1 x2) 89 | ;;(div-and-mod x1 x2) 90 | 91 | ;;按照数字理论的整数除法和对应的remainder或者modulo.都可以用在实数上 92 | ;;div-and-mod 是一个多值返回,同时包括商和余数 93 | 94 | 95 | ;;div0 mod0 div0-and-mod0 和上一组类似 96 | ;;判别式是 x1=n*x2+m -|x2/2| <= m < |x2/2| 97 | 98 | 99 | 100 | ;;(truncate real) 101 | ;;real向0方向最接近的一个整数 102 | 103 | 104 | 105 | ;;(flool real) 106 | ;;real向负无穷方向最接近的一个整数 107 | 108 | 109 | ;;(ceiling real) 110 | 111 | ;;real 在正无穷方向最接近的一个整数 112 | 113 | ;;(round real) 114 | ;;real最接近的整数 115 | 116 | ;;(abs real) 117 | ;;real的绝对值 118 | 119 | ;;(max real1 real2 real3 ...) 120 | ;;real1 real2 。。。的最大值 121 | 122 | 123 | ;;min 最小值 124 | 125 | ;;(gcd int ...) 126 | ;;最大公约数 127 | (gcd) 128 | (gcd 34) 129 | (gcd 33 15) 130 | (gcd 70 -42 28) 131 | 132 | ;;(lcm int ...) 133 | ;;int的最小公倍数 134 | 135 | (lcm) 136 | (lcm 34) 137 | (lcm 33.0 15.0) 138 | (lcm 70 -42 28) 139 | (lcm 17.0 0) 140 | 141 | 142 | ;;(expt num1 num2) 143 | ;;num1的num2次 144 | 145 | (expt 2 10) 146 | (expt 2 -10) 147 | (expt 2 -10.0) 148 | (expt -1/2 5) 149 | (expt 3.0 3) 150 | (expt +i 2) 151 | 152 | 153 | ;;exact inexact 154 | ;; exact->inexact inexact->exact 155 | 156 | ;;将数字进行精确和非精确的转换 157 | 158 | 159 | 160 | -------------------------------------------------------------------------------- /TSPL/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (let ([x (call/cc (lambda (k) k))]) 4 | (x (lambda (ignore) (display ignore)))) 5 | 6 | (let f () 7 | (display "hello") 8 | (f)) 9 | -------------------------------------------------------------------------------- /TSPL/transhcan.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (call/cc (lambda (k) (* 5 4))) 3 | 4 | (call/cc (lambda (k) (* 5 (k 4)))) 5 | 6 | ;;a list of number --> a number 7 | ;;计算一个列表的数字的乘积 8 | (define (prducrt ls) 9 | (call/cc (lambda (break) 10 | (let f ([ls ls]) 11 | (cond 12 | [(empty? ls) 1] 13 | [(= (first ls) 0) (break 0)] 14 | [else (* (first ls) (f (rest ls)))]))))) 15 | 16 | (prducrt '(1 2 3 4 5 6 0 2434 45)) 17 | 18 | 19 | 20 | (let ([x (call/cc (lambda (k) k))]) 21 | (x (lambda (nothing) 22 | (begin (displayln nothing) 23 | "hi")))) 24 | 25 | ;;好像明白一点什么叫延续了 26 | 27 | (define lwp-list '()) 28 | 29 | 30 | ;;将一个任务加入list的结尾 31 | (define (lwp thunk) 32 | (set! lwp-list (append lwp-list (list thunk)))) 33 | 34 | ;;从列表取出一个任务来执行 35 | (define (start) 36 | (let ([p (first lwp-list)]) 37 | (set! lwp-list (rest lwp-list)) 38 | (p))) 39 | 40 | (define (pause) 41 | (call/cc (lambda (k) 42 | (lwp (lambda () (k #f))) 43 | (start)))) 44 | 45 | (lwp (lambda () 46 | (let f () 47 | (pause) 48 | (display "h") 49 | (f)))) 50 | (lwp (lambda () (let f () (pause) (display "e") (f)))) 51 | (lwp (lambda () (let f () (pause) (display "y") (f)))) 52 | (lwp (lambda () (let f () (pause) (display "!") (f)))) 53 | (lwp (lambda () (let f () (pause) (newline) (f)))) 54 | 55 | ;;(start) 56 | 57 | ((first)) (list (lambda () (let f () (pause) (display "f") (f) ))) 58 | -------------------------------------------------------------------------------- /bp/lose.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require "tensor.rkt") 4 | (provide square-lose 5 | sqrt-lose) 6 | 7 | (define (auto-alpha target) 8 | (define (auto-alpha-inner x y) 9 | (cond 10 | [(< x 1) y] 11 | [else (auto-alpha-inner (* x 0.1) (* y 0.1))])) 12 | ;; (auto-alpha-inner gap 1) 13 | (auto-alpha-inner target 1)) 14 | 15 | 16 | ;;trensor expected-value alpha mini-lose continue iterate_n 17 | (define (square-lose t y mini-lose k i) 18 | (define lose (sqrt (sqr (- (tensor-get t) y)))) 19 | (cond 20 | [(> lose mini-lose) (tensor-update! t (* (auto-alpha y ) (- (tensor-get t) y)) )] 21 | [else (k i)]) 22 | lose) 23 | 24 | (define (sqrt-lose t y alpha mini-lose k i) 25 | (define lose (* (if (> (tensor-get t) y) 26 | 1 27 | -1) 28 | (sqrt (abs (- (tensor-get t) y))))) 29 | (cond 30 | [(> (abs lose) mini-lose) (tensor-update! t (* alpha 1/2 lose))] 31 | [else (k i)]) 32 | lose) 33 | 34 | -------------------------------------------------------------------------------- /bp/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "tensor.rkt") 3 | (require "operator.rkt") 4 | (require "lose.rkt") 5 | 6 | (define x (make-tensor 3)) 7 | (define y (make-tensor 4)) 8 | (define z (make-tensor 5)) 9 | 10 | (define q (ADD x y)) 11 | (define f (MUL q z)) 12 | 13 | (define (look) 14 | (writeln (format "X = ~a" (tensor-get x))) 15 | (writeln (format "Y = ~a" (tensor-get y))) 16 | (writeln (format "Z = ~a" (tensor-get z))) 17 | (writeln (format "F = ~a" (tensor-get f))) 18 | ) 19 | 20 | (call/cc (lambda (k) 21 | (for ([i (range 500)]) 22 | (writeln (format "~a iteration:" i)) 23 | ;; (look) 24 | (writeln 25 | (format "Loss = ~a" (square-lose f 0.1 0.001 k i))) 26 | (newline) 27 | ))) 28 | 29 | (look) 30 | 31 | -------------------------------------------------------------------------------- /bp/operator.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "tensor.rkt") 3 | 4 | (provide (all-defined-out)) 5 | 6 | 7 | ;; in 输入 list of tensor 例如 (list x y) 8 | ;; op 计算函数 function 参数对应计算的数量 参数为 tensor中的值 而非整个tensor 9 | ;; gradient 梯度下降函数 在反向传播时被调用 负责梯度下降和更新 10 | (define (make-operator in op gradient) 11 | (define (abstract-op) (apply op (map tensor-get in)) ) 12 | (define result (make-tensor (abstract-op))) 13 | 14 | (define (abstract-gradient) (apply gradient 15 | (cons (tensor-get-delta result) 16 | (map tensor-get in)))) 17 | (for ([i in]) 18 | (tensor-add-forward i 19 | (lambda () 20 | (tensor-set! result (abstract-op))))) 21 | (tensor-add-backward result abstract-gradient) 22 | 23 | result) 24 | 25 | (define (ADD x y) 26 | (define (add-op _x _y) 27 | (+ _x _y)) 28 | (define (gradient delta _x _y) 29 | (tensor-update! x delta) 30 | (tensor-update! y delta)) 31 | (make-operator (list x y) add-op gradient) 32 | ) 33 | 34 | (define (MUL x y) 35 | (define (mul-op _x _y) 36 | (* _x _y)) 37 | (define (gradient delta _x _y) 38 | (tensor-update! x (* delta _y)) 39 | (tensor-update! y (* delta _x))) 40 | (make-operator (list x y) mul-op gradient) 41 | ) 42 | 43 | (define (DIV x y) 44 | (define (div-op _x _y) 45 | (/ _x _y)) 46 | (define (gradient delta _x _y) 47 | (tensor-update! x (* delta (/ 1 _y))) 48 | (tensor-update! y (* delta (- (/ _x (sqr _y)))))) 49 | (make-operator (list x y) div-op gradient) 50 | ) 51 | 52 | 53 | (define (MINUS x y) 54 | (define (minus-op _x _y) 55 | (- _x _y)) 56 | (define (gradient delta _x _y) 57 | (tensor-update! x delta) 58 | (tensor-update! y (- delta))) 59 | (make-operator (list x y) minus-op gradient)) 60 | 61 | (define (SIN x) 62 | (define (sin-op _x) 63 | (sin _x)) 64 | (define (gradient delta _x) 65 | (tensor-update! x (* (cos _x) delta))) 66 | (make-operator (list x) sin-op gradient) 67 | ) 68 | 69 | (define (COS x) 70 | (define (cos-op _x) 71 | (cos _x)) 72 | (define (gradient delta _x) 73 | (tensor-update! x (* delta (- (sin _x))))) 74 | (make-operator (list x) cos-op gradient) 75 | ) 76 | 77 | (define (TAN x) 78 | (define (tan-op _x) 79 | (tensor-set! x (tan _x))) 80 | (define (gradient delta _x) 81 | (tensor-update! x (* delta (/ 1 (sqr (cos _x)))))) 82 | (make-operator (list x) tan-op gradient) 83 | ) 84 | 85 | (define (LN x) 86 | (define (ln-op _x) 87 | (log _x)) 88 | (define (gradient delta _x) 89 | (tensor-update! x (* delta (/ 1 _x)))) 90 | (make-operator (list x) ln-op gradient) 91 | ) 92 | 93 | (define (EXP x) 94 | (define (exp-op _x) 95 | (exp _x)) 96 | (define (gradient delta _x) 97 | (tensor-update! x (* delta (exp _x)))) 98 | (make-operator (list x) exp-op gradient) 99 | ) 100 | 101 | (define (EXPT x y) 102 | (define (power-op _x _y) 103 | (expt _x _y)) 104 | (define (gradient delta _x _y) 105 | (tensor-update! x (* delta (* _y (expt _x (- _y 1))))) 106 | (tensor-update! y (* delta (* (log _x) 107 | (exp (* _y (log _x))))))) 108 | (make-operator (list x y) power-op gradient)) 109 | 110 | (define (LOG x y) 111 | (define (log-op _x _y) 112 | (/ (log (tensor-get _x)) 113 | (log (tensor-get _y)))) 114 | (define (gradient delta _x _y) 115 | (tensor-update! x (* delta (- (/ (log _y) 116 | (* _x (sqr (log _x))))))) 117 | (tensor-update! y (* delta (/ 1 (* _y (log _x)))))) 118 | (make-operator (list x y) log-op gradient)) 119 | 120 | -------------------------------------------------------------------------------- /bp/readme.md: -------------------------------------------------------------------------------- 1 | 尝试实现反向传播算法 2 | -------------------------------------------------------------------------------- /bp/tensor.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide make-tensor 4 | tensor? 5 | tensor-get 6 | tensor-get-delta 7 | tensor-set! 8 | tensor-update! 9 | tensor-add-forward 10 | tensor-add-backward) 11 | 12 | (define (make-tensor n) 13 | (let ([content n] 14 | [type 'tensor] 15 | [delta 0] 16 | [forward-procs '()] 17 | [backward-procs '()]) 18 | 19 | (define (setter n) 20 | (set! content n) 21 | (for-each (lambda (x) (x)) 22 | forward-procs)) 23 | 24 | (define (update d) 25 | (set! delta d) 26 | (if (empty? backward-procs) 27 | (begin 28 | (set! content (- content d)) 29 | (for-each (lambda (x) (x)) 30 | forward-procs)) 31 | (for-each (lambda (x) (x)) 32 | backward-procs) 33 | )) 34 | 35 | (define (add-forward-procs p) 36 | (set! forward-procs (cons p forward-procs))) 37 | 38 | (define (add-backward-procs p) 39 | (set! backward-procs (cons p backward-procs))) 40 | 41 | (define (dispatcher action) 42 | (cond 43 | [(symbol=? action 'get) content] 44 | [(symbol=? action 'get-delta) delta] 45 | [(symbol=? action 'set) setter] 46 | [(symbol=? action 'update) update] 47 | [(symbol=? action 'add-forward) add-forward-procs] 48 | [(symbol=? action 'add-backward) add-backward-procs] 49 | [(symbol=? action 'get-type) type] 50 | [else (error "Unknow action")])) 51 | 52 | dispatcher)) 53 | 54 | 55 | (define (tensor? t) 56 | (with-handlers ( [exn:fail? (lambda (e) #f)]) 57 | (symbol=? 'tensor (t 'get-type)))) 58 | 59 | (define (tensor-get t) 60 | (t 'get)) 61 | 62 | (define (tensor-get-delta t) 63 | (t 'get-delta)) 64 | 65 | (define (tensor-set! t n) 66 | ((t 'set) n)) 67 | 68 | (define (tensor-update! t delta) 69 | ((t 'update) delta)) 70 | 71 | (define (tensor-add-forward t a) 72 | ((t 'add-forward) a)) 73 | 74 | (define (tensor-add-backward t a) 75 | ((t 'add-backward) a)) 76 | -------------------------------------------------------------------------------- /nothing/WebWiki.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require web-server/servlet 3 | web-server/servlet-env) 4 | 5 | (require net/uri-codec) 6 | 7 | (require file/sha1 8 | net/base64) 9 | 10 | (define root (path->string (current-directory))) 11 | 12 | ;;passwd文件的路径 13 | 14 | (define passwd-file (string-append root "passwd")) 15 | 16 | (define (any? pred list) 17 | ;查看是否有任何值list之中有和pred匹配的 18 | (match list 19 | ['() #f] 20 | [(cons hd tl) 21 | (or (pred hd) (any? pred (cdr list)))])) 22 | 23 | ;;检查密码的例行公事 24 | (define (htpasswd-credentials-valid? passwd-file username password) 25 | ;;检查用户信息是否和数据库中符合 26 | ;;假定所有条目使用"htpasswd -s"来sha1加密 27 | (define lines (call-with-input-file passwd-file 28 | (λ (port) (port->lines port)))) 29 | (define sha1-pass (sha1-bytes (open-input-bytes password))) 30 | 31 | ;;使用base64加密 32 | (define sha1-pass-b64 33 | (bytes->string/utf-8 (base64-encode sha1-pass #""))) 34 | 35 | ;;检测用户名和密码是否匹配 36 | (define (password-match? line) 37 | 38 | (define user:hash (string-split line ":")) 39 | (define user (car user:hash)) 40 | (define hash (cadr user:hash)) 41 | 42 | (match (string->list hash) 43 | ;;检查sha1前缀 44 | [`(#\{ #\S #\H #\A #\} . ,hashpass-chars) 45 | (define hashpass (list->string hashpass-chars)) 46 | (and (equal? username (string->bytes/utf-8 user)) 47 | (equal? hashpass sha1-pass-b64))] 48 | [else #f])) 49 | 50 | ;;检查是否有符合条件的一行 51 | (any? password-match? lines)) 52 | 53 | (define (req->user req) 54 | (match (request->basic-credentials req) 55 | [(cons user pass) user] 56 | [else #f])) 57 | 58 | (define (authenticated? req) 59 | (match (request->basic-credentials req) 60 | [(cons user pass) 61 | (htpasswd-credentials-valid? passwd-file user pass)] 62 | [else #f])) 63 | 64 | 65 | (define (hello-servlet req) 66 | (cond 67 | [(not (authenticated? req)) 68 | (response 69 | 401 #"Unauthorized" 70 | (current-seconds) 71 | TEXT/HTML-MIME-TYPE 72 | (list 73 | (make-basic-auth-header 74 | "需要认证")) 75 | void)] 76 | [else (response/xexpr 77 | #:preamble #"string/utf-8 (req->user req)) "!"))))])) 82 | 83 | 84 | (serve/servlet hello-servlet 85 | #:servlet-regexp #rx"") 86 | 87 | 88 | -------------------------------------------------------------------------------- /nothing/lambda匿名递归.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;http://shellfly.org/blog/2015/01/07/yi-the-y-combinator-slight-return/ 4 | 5 | ;阶乘函数 6 | ;Number->N! 7 | (define (f n) 8 | (cond 9 | [(= 0 n) 1] 10 | [else (* n (f (- n 1)))])) 11 | 12 | ;;将上面的显示的自我调用的递归函数变成通过λ实现的匿名递归 13 | (define almost_factorial 14 | (lambda (f) 15 | (lambda (n) 16 | (if (= n 0) 17 | 1 18 | (* n (f (- n 1))))))) 19 | 20 | (define almost_fibonacci 21 | (lambda (f) 22 | (lambda (n) 23 | (cond ((= n 0) 0) 24 | ((= n 1) 1) 25 | (else (+ (f (- n 1)) (f (- n 2)))))))) 26 | 27 | ;目的实现Y 28 | ;(define fibonacci (Y almost_fibonacci)) 29 | ;(define factorial (Y almost_factorial)) 30 | 31 | ;almost_f -> f 32 | ;f是我想要的递归函数 33 | ;(Y almost_f)<==>f 34 | ;(almost_f f)<==>f 35 | ;(Y almost_f)<==>(almost_f f)<==>(almost_f (Y almost_f)) 36 | ;(λ (almost_f) (almost_f (Y almost_f)))) 37 | ;(λ (x) (x x)) 38 | (define (Y0 f) 39 | (f (Y0 f))) 40 | 41 | (define Y 42 | (lambda (f) 43 | (lambda (x) (x x) 44 | (lambda (x) (f (lambda (y) ((x x) y))))))) 45 | 46 | 47 | (define (Y2 f) 48 | (f (λ (x) (x (Y2 x))))) 49 | 50 | (define eternity 51 | (lambda (x) 52 | (eternity x))) 53 | 54 | (((lambda (n!) ;; 展开后成为 n0! 函数 55 | (lambda (n) 56 | (cond 57 | [(zero? n) 1] 58 | [else (* n (n! (- n 1)))]))) 59 | eternity) 4) 60 | 61 | 62 | ((lambda (f) ;; 函数 n1! 63 | (lambda (n) 64 | (cond 65 | [(zero? 0) 1] 66 | [else (* n (f (- n 1)))]))) 67 | ((lambda (n!) ;; 函数 n0! 68 | (lambda (n) 69 | (cond 70 | [(zero? n) 1] 71 | [else (* n (n! (- n 1)))]))) 72 | eternity)) 73 | 74 | ((lambda (f) ;; 函数 n<=2! 75 | (lambda (n) 76 | (cond 77 | [(zero? n) 1] 78 | [else (* n (f (- n 1)))]))) 79 | ((lambda (f) ;; 函数 n<=1! 80 | (lambda (n) 81 | (cond 82 | [(zero? 0) 1] 83 | [else (* n (f (- n 1)))]))) 84 | ((lambda (n!) ;; 函数 n0! 85 | (lambda (n) 86 | (cond 87 | [(zero? n) 1] 88 | [else (* n (n! (- n 1)))]))) 89 | eternity))) -------------------------------------------------------------------------------- /nothing/learn-vector.rkt: -------------------------------------------------------------------------------- 1 | ;vector 是一个固定长度的数组,可以存放任意的内容 2 | ;list不一样的是,vector的访问时间是一个常数,还可以更新其内容 3 | #lang racket 4 | 5 | ;;定义一个vector 6 | #("a" 'i 'b 3) 7 | 8 | ;;vector 作为一个表达式的时候可以指定其长度 9 | #4(baldwin bruce) 10 | ;;当长度不够时,似乎会以最后一个元素填充 11 | 12 | ;; #2(12 3 3 4 4 5) 13 | ;;当指定的元素数量比所给的多的时候会报错 14 | 15 | ;;还有一个隐式的规则 16 | '#(name (that tune)) 17 | ;这样的定义就会使(that tune)也是一个vector 18 | ;就是说其中的内容是嵌套定义的 19 | 20 | (vector-ref #(1 2 3 4 5 56) 0) 21 | 22 | 23 | ;;vector和list可以通过 vector->list 和list->vector 方便地进行转换 24 | ;循环时分配新的list有时候代价太大,这时候可以考虑使用 for/fold 25 | ;它对list 和vector 都适用 26 | (list->vector (map string-titlecase 27 | (vector->list #("three" "blind" "mice")))) 28 | 29 | ;;两个vector 是equal? 的 <==> 长度和元素 是equal?的 30 | ;;vector 可以被用作序列 31 | ;; Vectors generated by the default reader (see Reading Strings) are immutable. 32 | 33 | 34 | (display #4(1 2)) 35 | 36 | (vector->list #4(1 2)) 37 | 38 | 39 | ;;构造器 40 | (vector v ...) 41 | 42 | ;;谓词 43 | ;; (vector? v) 44 | 45 | -------------------------------------------------------------------------------- /nothing/newtown.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | 4 | ;牛顿解方程 5 | ;参数F guess ->root 6 | 7 | ;精度 8 | (define 精度 0.000000000000001) 9 | 10 | ;判断答案是否足够接近 11 | ;F,guess->boolean 12 | (define (good-enough? F guess) 13 | (if (or (< (* (F (+ guess 精度)) (F (- guess 精度)) ) 0) 14 | (= 0 (F guess))) 15 | true 16 | false)) 17 | 18 | ;定义dx 19 | (define dx 0.0000000001) 20 | 21 | ;得到某个点的导数 22 | (define (导 F guess) 23 | (/ (- (F (+ guess dx)) (F guess)) dx )) 24 | 25 | 26 | ;得到下一个guess 27 | ;F guess->guess 28 | (define (next F guess) 29 | (- guess (/ (F guess) (导 F guess )))) 30 | 31 | (define (newton F guess) 32 | (if (good-enough? F guess) 33 | guess 34 | (newton F (next F guess)))) 35 | 36 | ;;要求解的方程 37 | (define (F x) 38 | (* (- x 5) (- x 4))) 39 | 40 | (newton F -1) 41 | -------------------------------------------------------------------------------- /nothing/passwd: -------------------------------------------------------------------------------- 1 | richard:{SHA}fEqNCco3Yq9h5ZUglD3CZJT4lBs= 2 | -------------------------------------------------------------------------------- /nothing/stream.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require racket/stream) 4 | ;;stream 可以看作是一个特殊的数据结构可以用来表示无限的数据 5 | ;;可以将它看做是一个无限长的list 6 | ;;在实现上来看stream是一个元素加上一个promise 7 | ;;通过延时求值像是lazy的方式做到使用时才求值所以即使无限长但是不影响效率 8 | 9 | 10 | ;;延迟一个表达式的求值 11 | ;;由于racket不是惰性求值所以实现delay有点困难 12 | ;;以下代码并不正确 13 | (define (delay exp) 14 | (λ () exp)) 15 | 16 | (define a-delay 17 | (delay '(display "hello delay"))) 18 | 19 | ;;求解delay 20 | ;;实现在racket中并不正确 21 | (define (force a-delay) 22 | (eval a-delay)) 23 | 24 | ;;n -> stream 25 | ;;返回从n开始的stream 26 | (define (my-nature a) 27 | (stream-cons a (my-nature (+ 1 a)) )) 28 | 29 | ;;自然数序列 30 | (define 0->infinity (my-nature 0)) 31 | 32 | (define f '()) 33 | (define r 0->infinity) 34 | 35 | ;; (for ([i (range 0 100)]) 36 | ;; (begin 37 | ;; (set! f (stream-first r)) 38 | ;; (set! r (stream-rest r)) 39 | ;; (displayln f))) 40 | 41 | 42 | ;;stream n -> stream 43 | ;;将stream中的前n个取出 44 | (define (stream-take s n) 45 | (define (iterator s k) 46 | (cond 47 | [(equal? empty-stream s) (error "stream长度小于" n)] 48 | [(= k n) (stream-first s)] 49 | [else (stream-cons (stream-first s ) (stream-take (stream-rest s ) (add1 k)))])) 50 | (iterator s 1)) 51 | 52 | 53 | ;;stream n -> list 54 | ;;将stream的前n个转换为 55 | (define (my-stream->list s n) 56 | (cond 57 | [(stream-empty? s) '()] 58 | [(zero? n) '()] 59 | [else (cons (stream-first s) (my-stream->list (stream-rest s) (- n 1)))])) 60 | 61 | 62 | ;;list -> stream 63 | ;;用list构造一个stream 64 | (define (my-list->stream l) 65 | (cond 66 | [(empty? l) empty-stream] 67 | [else (stream-cons (first l) 68 | (my-list->stream (rest l)))])) 69 | 70 | 71 | ;;一些常用的流函数 72 | 73 | ;;将两个stream相加,如果都是无限的流则不会终止 74 | (define (stream-add s1 s2) 75 | (cond 76 | [(stream-empty? s1) empty-stream] 77 | [(stream-empty? s2) empty-stream] 78 | [else (stream-cons (+ (stream-first s1) 79 | (stream-first s2)) 80 | (stream-add (stream-rest s1) 81 | (stream-rest s2)))])) 82 | 83 | 84 | ;;使用流定义斐波那契数列 85 | 86 | 87 | (define fib 88 | (letrec ([make-stream 89 | (λ (a b) 90 | (stream-cons a (make-stream b (+ a b))))] 91 | ) 92 | (make-stream 0 1))) 93 | 94 | 95 | ;;可以通过calkin-wilf 数来遍历有理数 96 | 97 | (define (midl-see a) 98 | (display "\t") 99 | ;(displayln a) 100 | ) 101 | 102 | (my-stream->list fib 100) 103 | 104 | 105 | ;;测试模块 106 | (module+ test 107 | (require rackunit) 108 | (display "hello test ")) 109 | -------------------------------------------------------------------------------- /nothing/λ匿名.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;原函数 3 | (define (f1 n) 4 | (cond 5 | [(= 0 n) 1] 6 | [else (* n (f1 (- n 1)))])) 7 | 8 | ;非显示的递归调用 9 | (define (f2_part self n) 10 | (cond 11 | [(= n 0) 1] 12 | [else (* n (self self (- n 1)))])) 13 | 14 | (define (f2 n) 15 | (f2_part f2_part n)) 16 | 17 | ;local 使之成为一个函数 18 | 19 | (define (f3 n) 20 | (local ( 21 | (define (part self n) 22 | (cond 23 | [(= n 0) 1] 24 | [else (* n (self self (- n 1)))])) 25 | ) 26 | (part part n))) 27 | 28 | ;加入λ 29 | (define (f4 n) 30 | ((λ (x) (x x n)) 31 | (λ (f n) 32 | (if (= n 0) 1 (* n (f f (- n 1))))))) 33 | 34 | ;去掉函数名 35 | 36 | ((λ (n) 37 | ((λ (x) (x x n)) 38 | (λ (f n) 39 | (if (= n 0 ) 1 (* n (f f (- n 1))))))) 6) 40 | ;成功,没有函数名的递归函数 41 | 42 | 43 | ;;使之化简,然后一般化 44 | ;先把n拿出来试试 45 | (define (f5 n) 46 | ((λ (x) (x x n)) 47 | (λ (f n) 48 | (if (= n 0) 1 (* n (f f (- n 1))))))) 49 | 50 | ;将两个参数的匿名函数转换成嵌套的单参匿名函数 51 | (f5 6) 52 | 53 | 54 | ;;以下内容为博客转载,非原创 55 | (define (part-f1 self) 56 | ((lambda (f) 57 | (lambda (n) 58 | (if (= n 0) 59 | 1 60 | (* n (f (- n 1)))))) 61 | (self self))) 62 | (define f6 (part-f1 part-f1)) 63 | 64 | ;;抄袭结束 65 | 66 | (define almost_f 67 | (lambda (f) 68 | (lambda (n) 69 | (if (= n 0) 70 | 1 71 | (* n (f (- n 1))))))) 72 | 73 | 74 | -------------------------------------------------------------------------------- /nothing/简单的解释器.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;以下代码出自王垠之手,确实很简单,但是也解释的十分通俗易懂 4 | ;;; 以下三个定义 env0, ext-env, lookup 是对环境(environment)的基本操作: 5 | 6 | ;; 空环境 7 | (define env0 '()) 8 | 9 | ;; 扩展。对环境 env 进行扩展，把 x 映射到 v，得到一个新的环境 10 | (define ext-env 11 | (lambda (x v env) 12 | (cons `(,x . ,v) env))) 13 | 14 | ;; 查找。在环境中 env 中查找 x 的值。如果没找到就返回 #f 15 | (define lookup 16 | (lambda (x env) 17 | (let ([p (assq x env)]) 18 | (cond 19 | [(false? p) #f] 20 | [else (cdr p)])))) 21 | 22 | ;; 闭包的数据结构定义，包含一个函数定义 f 和它定义时所在的环境 23 | (struct Closure (f env)) 24 | 25 | ;; 解释器的递归定义（接受两个参数，表达式 exp 和环境 env） 26 | ;; 共 5 种情况（变量，函数，绑定，调用，数字，算术表达式） 27 | (define interp 28 | (lambda (exp env) 29 | (match exp ; 对exp进行模式匹配 30 | [(? symbol? x) ; 变量 31 | (let ([v (lookup x env)]) 32 | (cond 33 | [(false? v) 34 | (error "undefined variable" x)] 35 | [else v]))] 36 | [(? number? x) x] ; 数字 37 | [`(lambda (,x) ,e) ; 函数 38 | (Closure exp env)] 39 | [`(let ([,x ,e1]) ,e2) ; 绑定 40 | (let ([v1 (interp e1 env)]) 41 | (interp e2 (ext-env x v1 env)))] 42 | [`(,e1 ,e2) ; 调用 43 | (let ([v1 (interp e1 env)] 44 | [v2 (interp e2 env)]) 45 | (match v1 46 | [(Closure `(lambda (,x) ,e) env-save) 47 | (interp e (ext-env x v2 env-save))]))] 48 | [`(,op ,e1 ,e2) ; 算术表达式 49 | (let ([v1 (interp e1 env)] 50 | [v2 (interp e2 env)]) 51 | (match op 52 | ['+ (+ v1 v2)] 53 | ['- (- v1 v2)] 54 | ['* (* v1 v2)] 55 | ['/ (/ v1 v2)]))]))) 56 | 57 | ;; 解释器的“用户界面”函数。它把 interp 包装起来，掩盖第二个参数，初始值为 env0 58 | (define r2 59 | (lambda (exp) 60 | (interp exp env0))) 61 | -------------------------------------------------------------------------------- /projectEuler/1.cpp: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | using namespace std; 4 | int main() { 5 | int sum3 = (3 + 999) * 999 / 3 / 2; 6 | int sum5 = (5 + 995) * 995 / 5 / 2; 7 | int sum15 = (15 + 990) * 990 / 15 / 2; 8 | int sum = sum3 + sum5 - sum15; 9 | printf("%d", sum); 10 | 11 | return 0; 12 | } 13 | -------------------------------------------------------------------------------- /projectEuler/1.ss: -------------------------------------------------------------------------------- 1 | ;; https://pe-cn.github.io/1/ 2 | 3 | ;;暴力枚举 4 | (define (solve x) 5 | (define (valid-number? x) 6 | (or (= 0 (mod x 3)) 7 | (= 0 (mod x 5)))) 8 | (define (solve-inner x acc) 9 | (cond 10 | [(= 0 x) acc] 11 | [else (solve-inner (- x 1) 12 | (if (valid-number? x) 13 | (+ x acc) 14 | acc))])) 15 | 16 | (solve-inner x 0 )) 17 | 18 | (solve 999) 19 | 20 | 21 | ;; 3的倍数 和 5 的倍数 都是等差数列, 22 | ;; 求和之后去除公共项 23 | 24 | ;;up 上限 25 | (define (solve2) 26 | (define sum3 (/ (* 333 (+ 3 999)) 2)) 27 | (define sum5 (/ (* 199 (+ 5 995)) 2)) 28 | (define sum15 (/ (* 66 (+ 15 990)) 2)) 29 | (- (+ sum3 sum5) sum15)) 30 | 31 | 32 | ;;;;;;;;;;;;;;;;;性能比较 33 | (time (solve 999)) 34 | (time (solve2)) 35 | 36 | ;; (time (solve 999)) 37 | ;; no collections 38 | ;; 0.000033022s elapsed cpu time 39 | ;; 0.000032000s elapsed real time 40 | ;; 0 bytes allocated 41 | ;; 233168 42 | ;; > (time (solve2)) 43 | ;; (time (solve2)) 44 | ;; no collections 45 | ;; 0.000000043s elapsed cpu time 46 | ;; 0.000000000s elapsed real time 47 | ;; 0 bytes allocated 48 | ;; 233168 49 | -------------------------------------------------------------------------------- /projectEuler/2.ss: -------------------------------------------------------------------------------- 1 | (define (solve a b acc) 2 | (cond 3 | [(> b 4000000) acc] 4 | [else (solve b (+ a b) 5 | (if (odd? b) acc (+ b acc)))])) 6 | 7 | (solve 1 2 0) 8 | 9 | ;;偶数斐波那契数列可以有递推公式 10 | 11 | (define (solve2 x y acc) 12 | (cond 13 | [(> y 4000000) acc] 14 | [else (solve2 y (+ (* 4 y) x) (+ acc y))])) 15 | 16 | (solve2 2 8 2) 17 | -------------------------------------------------------------------------------- /rackUnitExample/coverage/assets/app.js: -------------------------------------------------------------------------------- 1 | window.onload = function() { 2 | 3 | var extractDataFromRow = function(tr, className) { 4 | var td = tr.querySelector('td.' + className); 5 | var a = td.querySelector('a'); 6 | if (a) { 7 | return a.innerHTML; 8 | } else { 9 | return td.innerHTML; 10 | } 11 | }; 12 | 13 | var removeRows = function(table, rows) { 14 | for (var i = 0; i < rows.length; i++) { 15 | table.removeChild(rows[i]); 16 | } 17 | }; 18 | 19 | var sortTable = function(className, compare) { 20 | var table = document.querySelector('table.file-list tbody'); 21 | var rows = Array.prototype.slice.call(table.querySelectorAll('tr'), 0); 22 | removeRows(table, rows); 23 | 24 | rows.sort(function(a, b) { 25 | var aActual = extractDataFromRow(a, className); 26 | var bActual = extractDataFromRow(b, className); 27 | return compare(aActual, bActual); 28 | }); 29 | for (var i = 0; i < rows.length; i++) { 30 | rows[i].className = 'file-info' + (((i % 2) == 0) ? ' stripe' : ''); 31 | table.appendChild(rows[i]); 32 | } 33 | }; 34 | 35 | var oppositeArrowDirection = function(dir) { 36 | if (dir === 'up') { 37 | return 'down'; 38 | } else { 39 | return 'up'; 40 | } 41 | }; 42 | 43 | var createSorter = function(className, arrowDirection, compare, negativeCompare) { 44 | var sortClass = 'th.' + className + ' div.sort-icon-' + arrowDirection; 45 | var element = document.querySelector(sortClass); 46 | var clickHandler = function() { 47 | var oppArrowDirection = oppositeArrowDirection(arrowDirection); 48 | sortTable(className, compare); 49 | element.removeEventListener('click', clickHandler); 50 | element.className = 'sort-icon-' + oppArrowDirection; 51 | createSorter(className, oppArrowDirection, negativeCompare, compare); 52 | }; 53 | element.addEventListener('click', clickHandler); 54 | }; 55 | 56 | var stringCompareAsc = function(a, b) { return a.localeCompare(b); }; 57 | var stringCompareDesc = function(a, b) { return b.localeCompare(a); }; 58 | var floatCompareAsc = function(a, b) { return parseFloat(a) - parseFloat(b); }; 59 | var floatCompareDesc = function(a, b) { return parseFloat(b) - parseFloat(a); }; 60 | 61 | createSorter('file-name', 'up', stringCompareDesc, stringCompareAsc); 62 | createSorter('coverage-percentage', 'up', floatCompareAsc, floatCompareDesc); 63 | createSorter('covered-expressions', 'up', floatCompareAsc, floatCompareDesc); 64 | createSorter('uncovered-expressions', 'up', floatCompareAsc, floatCompareDesc); 65 | createSorter('total-expressions', 'up', floatCompareAsc, floatCompareDesc); 66 | sortTable('coverage-percentage', floatCompareAsc); 67 | }; 68 | -------------------------------------------------------------------------------- /rackUnitExample/coverage/assets/main.css: -------------------------------------------------------------------------------- 1 | .code { 2 | display: table; 3 | font-family: "Lucida Console", Monaco, monospace; 4 | } 5 | 6 | .uncovered { 7 | color:red; 8 | } 9 | 10 | .covered { 11 | color:green; 12 | } 13 | 14 | .total-coverage { 15 | font-size: 2em; 16 | } 17 | 18 | .irrelevant {} 19 | 20 | table.file-list { 21 | width: 100%; 22 | border-collapse: collapse; 23 | } 24 | 25 | td, th { 26 | text-align: center; 27 | padding: 10px 10px; 28 | border-bottom: 1px solid; 29 | font-size: 1.2em; 30 | } 31 | 32 | td.file-name, th.file-name { 33 | text-align: left; 34 | } 35 | 36 | td a, td a:visited { 37 | text-decoration: none; 38 | color: #07A; 39 | } 40 | 41 | tr.stripe, :target { 42 | background-color: #F5F5EC; 43 | } 44 | 45 | div.report-container { 46 | width: 60%; 47 | margin: 0 20%; 48 | } 49 | 50 | .file-info div { 51 | display: inline-block; 52 | margin-bottom: 1em; 53 | padding-right: 2em; 54 | } 55 | 56 | div.line-numbers { 57 | display: table-cell; 58 | padding-right: 1em; 59 | text-align: right; 60 | } 61 | 62 | .line-numbers a { 63 | color: black; 64 | text-decoration: none; 65 | } 66 | 67 | .line-numbers a:hover { 68 | color: blue; 69 | text-decoration: underline; 70 | } 71 | 72 | div.file-lines { 73 | display: table-cell; 74 | } 75 | 76 | div.lines-wrapper { 77 | display: table-row; 78 | } 79 | 80 | /* Sorting Triangles */ 81 | 82 | .sort-icon-up { 83 | cursor: pointer; 84 | display: inline-block; 85 | margin-left: 0.5em; 86 | margin-bottom: 0.2em; 87 | 88 | width: 0px; 89 | height: 0px; 90 | border-left: 0.3em solid transparent; 91 | border-right: 0.3em solid transparent; 92 | border-bottom: 0.3em solid black; 93 | } 94 | 95 | .sort-icon-down { 96 | cursor: pointer; 97 | display: inline-block; 98 | margin-left: 0.5em; 99 | margin-bottom: 0.2em; 100 | 101 | width: 0px; 102 | height: 0px; 103 | border-left: 0.3em solid transparent; 104 | border-right: 0.3em solid transparent; 105 | border-top: 0.3em solid black; 106 | } 107 | -------------------------------------------------------------------------------- /rackUnitExample/coverage/file.html: -------------------------------------------------------------------------------- 1 |

expr: 100%

#lang racket/base

(define (my-+ a b)
  (if (zero? a)
      b
      (my-+ (sub1 a) (add1 b))))

(define (my-* a b)
  (if (zero? a)
      b
      (my-* (sub1 a) (my-+ b b))))

(provide my-+
         my-*)

(module+ test
  (require rackunit)
  (check-equal? (my-+ 1 1) 2 "Simple addition")
  (check-equal? (my-* 1 2) 4 "Simple multiplication")
  )
-------------------------------------------------------------------------------- /rackUnitExample/coverage/index.html: -------------------------------------------------------------------------------- 1 |
Total Project Coverage: 100%
File
Coverage Percentage
Covered Expressions
Uncovered Expressions
Total Expressions
file.rkt10051051
-------------------------------------------------------------------------------- /rackUnitExample/file-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rackunit 4 | "file.rkt") 5 | 6 | 7 | (check-equal? (my-+ 1 1) 2 "Simple addition") 8 | (check-equal? (my-* 1 2) 2 "Simple multiplication") 9 | 10 | 11 | (test-case 12 | "List has length 4 and all elements even" 13 | (let ([lst (list 2 4 6 9)]) 14 | (check = (length lst) 4) 15 | (for-each 16 | (lambda (elt) 17 | (check-pred even? elt)) 18 | lst))) 19 | 20 | -------------------------------------------------------------------------------- /rackUnitExample/file.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (define (my-+ a b) 4 | (if (zero? a) 5 | b 6 | (my-+ (sub1 a) (add1 b)))) 7 | 8 | (define (my-* a b) 9 | (if (zero? a) 10 | b 11 | (my-* (sub1 a) (my-+ b b)))) 12 | 13 | (provide my-+ 14 | my-*) 15 | 16 | (module+ test 17 | (require rackunit) 18 | (check-equal? (my-+ 1 1) 2 "Simple addition") 19 | (check-equal? (my-* 1 2) 4 "Simple multiplication") 20 | ) 21 | -------------------------------------------------------------------------------- /sicp/1.1.sc: -------------------------------------------------------------------------------- 1 | 10 ;10 2 | (+ 5 3 4) ;12 3 | (- 9 1) ;8 4 | (/ 6 2) ;3 5 | (+ (* 2 4) (- 4 6));6 6 | 7 | (define a 3) 8 | (define b (+ a 1)) 9 | 10 | (+ a b (* a b)); 19 11 | 12 | (= a b); #f 13 | 14 | (if (and (> b a) (< b (* a b))) 15 | b 16 | a) ;4 17 | 18 | (cond ((= a 4) 6) 19 | ((= b 4) (+ 6 7 a)) 20 | (else 25));16 21 | 22 | (+ 2 (if (> b a) b a)); 6 23 | 24 | 25 | (* (cond ((> a b) a) 26 | ((< a b) b) 27 | (else -1)) 28 | (+ a 1));16 29 | 30 | 31 | -------------------------------------------------------------------------------- /sicp/1.10.sc: -------------------------------------------------------------------------------- 1 | ;;阿克曼方程 2 | (define (A x y) 3 | (cond ((= y 0) 0) 4 | ((= x 0) (* 2 y)) 5 | ((= y 1) 2) 6 | (else (A (- x 1) (A x (- y 1)))))) 7 | 8 | (A 1 10) 9 | (A 2 4) 10 | (A 3 3) 11 | 12 | ;; (A 1 4) 13 | ;; (A 0 (A 1 3)) 14 | ;; (* 2 (A 0 (A 1 2))) 15 | ;;（A 1 N) =2^n 16 | 17 | ;; (A 2 2) 18 | ;; (A 1 (A 2 1)) 19 | ;; (A 1 2) =2^2 20 | 21 | ;; (A 2 3) 22 | ;; (A 1 (A 2 2)) =2^4 23 | 24 | ;; (A 3 3) 25 | ;; (A 2 (A 3 2)) 26 | ;; (A 2 (A 2 (A 3 1))) 27 | ;; (A 2 (A 2 2)) 28 | ;; (A 2 4) 29 | ;; (A 1 (A 2 3)) 30 | ;; (A 1 16) = 2^16 31 | 32 | 33 | ;; (A 3 4) ;;危险 大概率你的电脑会跑不出来，函数的增长实在是太快了 34 | ;; (A 3 4) 35 | ;; (A 2 (A 3 3)) 36 | ;; (A 2 65536) 37 | ;; (A 1 (A 2 65535)) 38 | ;; (A 1 (A 1 (A 2 65534))) 39 | ;; (A 1 .... (A 2 1)) 40 | ;; (A 1 .... (A 1 2^1)) 41 | ;; (A 1 .... (A 1 2^(2^1)) ) 42 | ;; (A 1 2^(2^(2^ ....))) 43 | ;; 2的指数上有65536个 44 | 45 | (define (f n) (A 0 n)) ;2*n 46 | (define (g n) (A 1 n)) ;2^n 47 | (define (h n) (A 2 n)) ;2$n n级的指数 48 | (define (k n) (* 5 n n)) 49 | 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /sicp/1.11.sc: -------------------------------------------------------------------------------- 1 | (define (f-r n) 2 | (cond 3 | [(< n 3) n] 4 | [else (+ (f-r (- n 1)) 5 | (* 2 (f-r (- n 2))) 6 | (* 3 (f-r (- n 3))))])) 7 | 8 | (define (f-iter n) 9 | (define (f a b c count) 10 | (cond 11 | [(< count 3) count] 12 | [(= count 3) a] 13 | [else (f (+ a 14 | (* 2 b) 15 | (* 3 c)) 16 | a b (- count 1))])) 17 | (f 4 2 1 n)) 18 | 19 | (f-iter 10) 20 | (f-r 10) 21 | -------------------------------------------------------------------------------- /sicp/1.12.sc: -------------------------------------------------------------------------------- 1 | (define (pascal x y) 2 | (cond 3 | [(or (= y 1) 4 | (= y x)) 1] 5 | [else (+ (pascal (- x 1) (- y 1)) 6 | (pascal (- x 1) y))])) 7 | 8 | (pascal 5 3) 9 | -------------------------------------------------------------------------------- /sicp/1.13.sc: -------------------------------------------------------------------------------- 1 | ;;简单的假设检验就可以证明Fib(n) = .... 2 | ;;又可以证明后一项小于0.5 所以得证，这是最接近的正数 3 | ;;所以斐波那契数列可以有o(1)的算法可解其值，并且不需要精确计算sqrt(5)的次方 4 | -------------------------------------------------------------------------------- /sicp/1.14.dot: -------------------------------------------------------------------------------- 1 | digraph D{ 2 | A [label = "1"] 3 | B [label = "0.75"] 4 | C [label = "0.9"] 5 | D [label = "0.95"] 6 | E [label = "0.99"] 7 | 8 | A -> B [label=0.25] 9 | A -> C [label=0.1] 10 | A -> D [label=0.05] 11 | A -> E [label=0.01] 12 | 13 | B -> 0.5 -> 0.25 -> 0 14 | B -> 0.65 15 | B -> 0.7 16 | B -> 0.74 17 | 18 | 19 | C -> 0.65 20 | C -> 0.8 21 | C -> 0.85 22 | C -> 0.89 23 | 24 | } 25 | -------------------------------------------------------------------------------- /sicp/1.14.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shenxs/about-scheme/7260128257b5b99fd516116de0387df92e2027e2/sicp/1.14.png -------------------------------------------------------------------------------- /sicp/1.15.sc: -------------------------------------------------------------------------------- 1 | (define (cube x) (* x x x)) 2 | (define (p x) (- (* 3 x) (* 4 (cube x)))) 3 | (define count 0) 4 | (define (sine angle) 5 | (set! count (+ count 1)) 6 | (if (not (> (abs angle) 0.1)) angle 7 | (p (sine (/ angle 3.0))))) 8 | 9 | (sine 12.15) ;;计算12次 10 | 11 | ;;空间增长 lgN/lg2 12 | -------------------------------------------------------------------------------- /sicp/1.16.sc: -------------------------------------------------------------------------------- 1 | (define (fast-exp-iter x n) 2 | (define (fun a b n) 3 | (cond 4 | [(= 0 n) a] 5 | [(even? n) (fun a (* b b) (/ n 2))] 6 | [else (fun (* a b) b (- n 1))])) 7 | (fun 1 x n)) 8 | ;;简直太巧妙了 9 | (fast-exp-iter 2 10) 10 | -------------------------------------------------------------------------------- /sicp/1.17.sc: -------------------------------------------------------------------------------- 1 | (define (double x) 2 | (+ x x)) 3 | 4 | (define (halve x) 5 | (/ x 2)) 6 | 7 | (define (fast-multi a b) 8 | (define (iter x b) 9 | (cond 10 | [(= 0 b) 0] 11 | [(= 1 b) x] 12 | [(even? b) (iter (double x) (halve b))] 13 | [else (iter (+ x a) (- b 1))])) 14 | (iter a b)) 15 | 16 | (equal? 30 (fast-multi 5 6)) 17 | (equal? 0 (fast-multi 3 0)) 18 | (equal? 10 (fast-multi 10 1)) 19 | -------------------------------------------------------------------------------- /sicp/1.18.sc: -------------------------------------------------------------------------------- 1 | 2 | ;;使用迭代的方式在对数步数内计算处两个数的乘积 3 | 4 | (define (double a) 5 | (+ a a)) 6 | 7 | (define (halve a) 8 | (/ a 2)) 9 | 10 | (define (my-multi a b) 11 | (define (iter a x y) 12 | (cond 13 | [(= 0 y) a] 14 | [(even? y) (iter a (double x) (halve y))] 15 | [else (iter (+ a x) x (- y 1))])) 16 | (if (> a b) 17 | (iter 0 a b) 18 | (iter 0 b a))) 19 | 20 | 21 | (and (equal? 0 (my-multi 4 0)) 22 | (equal? 20 (my-multi 4 5)) 23 | (equal? 25 (my-multi 5 5)) 24 | (equal? 30 (my-multi 10 3))) 25 | 26 | (my-multi 10000 10000) 27 | 28 | -------------------------------------------------------------------------------- /sicp/1.19.sc: -------------------------------------------------------------------------------- 1 | ;;可以在对数时间内计算出斐波那契数列 2 | 3 | ;;在使用迭代的方式计算的时候可以发现是 4 | ;; a <- a+b 5 | ;; b <- a 6 | 7 | ;;可以将这种变换对应为矩阵计算 8 | ;;由于之前的乘法可以在log时间内完成 9 | ;;可以借鉴快速乘法的方式完成矩阵运算，即可在log时间内完成fib（n）的计算 10 | 11 | 12 | (define (fib n) 13 | (fib-iter 1 0 0 1 n)) 14 | 15 | 16 | (define (fib-iter a b p q count) 17 | (cond 18 | [(= count 0) b] 19 | [(even? count) 20 | (fib-iter a b 21 | (+ (* q q) (* p p)) 22 | (+ (* 2 p q) (* q q)) 23 | (/ count 2))] 24 | [else (fib-iter (+ (* b q) (* a q) (* a p)) 25 | (+ (* b p) (* a q)) 26 | p 27 | q 28 | (- count 1))])) 29 | 30 | (fib 30) 31 | 32 | ;;参考 33 | ;;http://jots-jottings.blogspot.com/2011/09/sicp-119-fibonacci-on-steroids.html 34 | ;;所有的计算全部使用log时间的算法最终会对比现有的平台更快吗？ 35 | ;;大概现代计算机的算术模块已经使用了这些技巧来加速基本的运算了,不过依然是非常快速 36 | 37 | -------------------------------------------------------------------------------- /sicp/1.2.sc: -------------------------------------------------------------------------------- 1 | (/ (+ 5 4 (- 2 (- 3 (+ 6 (/ 4 5))))) 2 | (* 3 (- 6 2) (- 2 7))) 3 | -------------------------------------------------------------------------------- /sicp/1.20.sc: -------------------------------------------------------------------------------- 1 | 2 | (define count 0) 3 | 4 | (define (my-remainder x y) 5 | (set! count (+ count 1)) 6 | (remainder x y)) 7 | 8 | (define (gcd a b) 9 | (define (iter x y) 10 | (if (= y 0) 11 | x 12 | (iter y (my-remainder x y)))) 13 | (if (> a b) 14 | (iter a b) 15 | (iter b a))) 16 | 17 | (gcd 206 40) 18 | count 19 | ;;一共四次 20 | -------------------------------------------------------------------------------- /sicp/1.21.sc: -------------------------------------------------------------------------------- 1 | (define (square x) 2 | (* x x)) 3 | 4 | (define (smallest-divisor n) 5 | (find-divisor n 2)) 6 | 7 | (define (find-divisor n test-divisor) 8 | (cond 9 | [(> (square test-divisor) n) n] 10 | [(divides? test-divisor n) test-divisor] 11 | [else (find-divisor n (+ test-divisor 1))])) 12 | 13 | (define (divides? a b) 14 | (= (remainder b a) 0)) 15 | 16 | 17 | (smallest-divisor 199) 18 | 19 | (smallest-divisor 1999) 20 | 21 | (smallest-divisor 19999) 22 | 23 | (smallest-divisor 199999) 24 | 25 | (smallest-divisor 1999999) 26 | 27 | (smallest-divisor 19999999) 28 | 29 | (smallest-divisor 199999999) 30 | 31 | (smallest-divisor 1999999999) 32 | 33 | 34 | -------------------------------------------------------------------------------- /sicp/1.22.sc: -------------------------------------------------------------------------------- 1 | (load "./1.21.sc") 2 | (define (prime? n) 3 | (= n (smallest-divisor n) )) 4 | (define (runtime) 5 | (+ (time-nanosecond (current-time)) 6 | (* 1000000000 (time-second (current-time))))) 7 | (define (timed-prime-test n) 8 | (newline) 9 | (display n) 10 | (start-prime-test n (runtime))) 11 | (define (start-prime-test n start-time) 12 | (if (prime? n) 13 | (report-prime (- (runtime) start-time)))) 14 | (define (report-prime elapsed-time) 15 | (display " *** ") 16 | (display elapsed-time)) 17 | (define (search-for-primes start next count) 18 | (cond 19 | [(= count 0) (newline)] 20 | [(prime? start) (timed-prime-test start) (search-for-primes (next start) next (- count 1))] 21 | [else (search-for-primes (next start) next count)])) 22 | 23 | (search-for-primes 19960101 (lambda (x) (if (odd? x) 24 | (+ x 2) 25 | (+ x 1))) 26 | 10) 27 | 28 | 29 | -------------------------------------------------------------------------------- /sicp/1.23.sc: -------------------------------------------------------------------------------- 1 | (define (square x) 2 | (* x x)) 3 | 4 | (define (smallest-divisor n next) 5 | (find-divisor n 2 next)) 6 | 7 | (define (next1 n) 8 | (cond 9 | [(= n 2) 3] 10 | [else (+ n 2)])) 11 | 12 | (define (next2 n) 13 | (+ n 1)) 14 | 15 | (define (find-divisor n test-divisor next) 16 | (cond 17 | [(> (square test-divisor) n) n] 18 | [(divides? test-divisor n) test-divisor] 19 | [else (find-divisor n (next test-divisor ) next)])) 20 | 21 | (define (divides? a b) 22 | (= (remainder b a) 0)) 23 | 24 | (define (prime? n next) 25 | (= n (smallest-divisor n next) )) 26 | 27 | (define (runtime) 28 | (+ (time-nanosecond (current-time)) 29 | (* 1000000000 (time-second (current-time))))) 30 | (define (timed-prime-test n next) 31 | (newline) 32 | (display n) 33 | (start-prime-test n (runtime) next)) 34 | (define (start-prime-test n start-time next) 35 | (if (prime? n next) 36 | (report-prime (- (runtime) start-time)))) 37 | (define (report-prime elapsed-time) 38 | (display " *** ") 39 | (display elapsed-time)) 40 | (define (search-for-primes start next count prime-next) 41 | (cond 42 | [(= count 0) (newline)] 43 | [(prime? start prime-next) 44 | (timed-prime-test start prime-next) 45 | (search-for-primes (next start) next (- count 1) prime-next)] 46 | [else (search-for-primes (next start) next count prime-next)])) 47 | 48 | (search-for-primes 1000000 (lambda (x) (if (odd? x) 49 | (+ x 2) 50 | (+ x 1))) 51 | 6 52 | next1) 53 | 54 | (search-for-primes 1000000 (lambda (x) (if (odd? x) 55 | (+ x 2) 56 | (+ x 1))) 57 | 6 58 | next2) 59 | 60 | ;;几乎就是两倍的关系 61 | 62 | -------------------------------------------------------------------------------- /sicp/1.24.sc: -------------------------------------------------------------------------------- 1 | (load "./utils.sc") 2 | 3 | (define (runtime) 4 | (time-second (current-time))) 5 | 6 | 7 | (define (time-prime-test n) 8 | (newline) 9 | (display n) 10 | (start-prime-test n (runtime))) 11 | 12 | (define (fast-mod a x y n) 13 | (cond 14 | [(= y 1) (remainder (* a x) n)] 15 | [(odd? y) (fast-mod (remainder (* a x) n) x (- y 1) n)] 16 | [else (fast-mod a (remainder (* x x) n) (/ y 2) n)])) 17 | 18 | (define (% x y n) 19 | (fast-mod 1 x y n)) 20 | 21 | (define (random-range x y) 22 | (+ x (random (- y x)))) 23 | 24 | (define (fast-prime? n) 25 | (if (= 1 (% (random-range 2 n) 26 | (- n 1) 27 | n)) 28 | #t 29 | #f)) 30 | 31 | (define (multi fun n) 32 | (cond 33 | [(= n 1) (fun)] 34 | [(fun) (multi fun (- n 1))] 35 | [else #f])) 36 | 37 | (define (find n) 38 | (cond 39 | [(= n 1) '()] 40 | [(multi (lambda () (fast-prime? n)) 5) (display n) (newline) (find (- n 1))] 41 | [else (find (- n 1))])) 42 | 43 | (find 10000) 44 | 45 | (timer (lambda () (fast-prime? 1000))) 46 | (timer (lambda () (fast-prime? 1000000))) 47 | (timer (lambda () (fast-prime? 1000000000000))) 48 | 49 | (fast-prime? 2047) 50 | 51 | 52 | -------------------------------------------------------------------------------- /sicp/1.3.sc: -------------------------------------------------------------------------------- 1 | (define (sum-square-of-max2 a b c) 2 | (cond 3 | [(and (> a b) 4 | (> a c)) (+ (* a a) 5 | (* b b))] 6 | [else (sum-square-of-max2 b c a)])) 7 | 8 | -------------------------------------------------------------------------------- /sicp/1.4.sc: -------------------------------------------------------------------------------- 1 | ;;如果b是正数就返回a+b 2 | ;;如果b是负数就返回a-b 3 | -------------------------------------------------------------------------------- /sicp/1.5.sc: -------------------------------------------------------------------------------- 1 | ;;是按需求值还是正常求值 2 | 3 | (define (p) (p)) 4 | 5 | (define (test x y) 6 | (if (= x 0) 0 y)) 7 | 8 | (test 0 (p)) 9 | 10 | ;;如果是正常求值会陷入死循环，如果是按需求值会返回0 11 | 12 | ;;亲测 ，chez scheme是正常求值，并不是按需求值，或者说惰性求值 13 | ;;所以会变成死循环。 14 | -------------------------------------------------------------------------------- /sicp/1.6.sc: -------------------------------------------------------------------------------- 1 | ;;会变成死循环，if不能用普通的函数定义 2 | ;;由于是正常求值，所以if 的每个clause会被执行所以就死循环了 3 | -------------------------------------------------------------------------------- /sicp/1.7.sc: -------------------------------------------------------------------------------- 1 | (define (average a b) 2 | (/ (+ a b) 2)) 3 | (define (improve guess x) 4 | (average guess (/ x guess))) 5 | 6 | (define (good-enough? guess x) 7 | (< (abs (- (* guess guess) x)) 8 | 0.001)) 9 | 10 | (define (sqrt x) 11 | 12 | (define (good-enough? guess x) 13 | (< (abs (- (* guess guess) x)) 14 | 0.001)) 15 | 16 | (define (sqrt-iter guess x count) 17 | (if (good-enough? guess x) 18 | (begin (display count) (newline) guess) 19 | (sqrt-iter (improve guess x) x (+ count 1)))) 20 | (sqrt-iter 1.0 x 1)) 21 | 22 | (define (sqrt-root x) 23 | (define last '()) 24 | (define (good-enough? guess) 25 | (cond 26 | [(null? last) (set! last guess) #f] 27 | [(< (abs (- guess last)) 0.001) #t] 28 | [else (set! last guess) #f] 29 | )) 30 | (define (sqrt-iter guess x count) 31 | (if (good-enough? guess ) 32 | (begin (display count) (newline) guess) 33 | (sqrt-iter (improve guess x) x (+ count 1)))) 34 | (sqrt-iter 1.0 x 1)) 35 | 36 | 37 | (sqrt 1000000) ;;迭代15次 38 | (sqrt 0.0001) ;;6 次 0.03 效果不是很好 39 | 40 | (sqrt-root 1000000) ;;对于较大的数值没有什么改进 41 | (sqrt-root 0.0001);; 相对于之前的版本在小数上更加精确 42 | -------------------------------------------------------------------------------- /sicp/1.8.sc: -------------------------------------------------------------------------------- 1 | (define (cube-root x) 2 | (define last '()) 3 | (define (good-enough? guess) 4 | (cond 5 | [(null? last) (set! last guess) #f] 6 | [(< (abs (- guess last)) 0.001) #t] 7 | [else (set! last guess) #f] 8 | )) 9 | (define (improve y x) 10 | (/ (+ (/ x (* y y)) (* 2 y)) 3)) 11 | (define (cube-root-iter guess x) 12 | (if (good-enough? guess) 13 | guess 14 | (cube-root-iter (improve guess x) x))) 15 | (cube-root-iter 1.0 x)) 16 | 17 | (cube-root 27) 18 | -------------------------------------------------------------------------------- /sicp/1.9.sc: -------------------------------------------------------------------------------- 1 | (define (+ a b) 2 | (if (= a 0) b (inc (+ (dec a) b)))) 3 | (define (+ a b) 4 | (if (= a 0) b (+ (dec a) (inc b)))) 5 | 6 | ;;前者是递归的 7 | ;;后者是迭代的 8 | -------------------------------------------------------------------------------- /sicp/sqrt.sc: -------------------------------------------------------------------------------- 1 | (define (sqrt x) 2 | (define (average a b) 3 | (/ (+ a b) 2)) 4 | (define (improve guess x) 5 | (average guess (/ x guess))) 6 | 7 | (define (good-enough? guess x) 8 | (< (abs (- (* guess guess) x)) 9 | 0.001)) 10 | 11 | (define (sqrt-iter guess x) 12 | (if (good-enough? guess x) 13 | guess 14 | (sqrt-iter (improve guess x) x))) 15 | (sqrt-iter 1.0 x)) 16 | 17 | (sqrt 9) 18 | 19 | -------------------------------------------------------------------------------- /sicp/utils.sc: -------------------------------------------------------------------------------- 1 | (define (runtime) 2 | (+ (time-nanosecond (current-time)) 3 | (* 1000000000 (time-second (current-time))))) 4 | 5 | (define (timer fun) 6 | (let ([start (runtime)]) 7 | (fun) 8 | (- (runtime) start))) 9 | -------------------------------------------------------------------------------- /web/.gitignore: -------------------------------------------------------------------------------- 1 | ./lib -------------------------------------------------------------------------------- /web/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 |
5 |

hello

6 |

7 | this is a try 8 | o 9 |

10 |
11 | 12 | -------------------------------------------------------------------------------- /web/lib/core/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /web/lib/core/README.md: -------------------------------------------------------------------------------- 1 | # core 2 | Scheme's tiny function 3 | -------------------------------------------------------------------------------- /web/lib/core/alist.sc: -------------------------------------------------------------------------------- 1 | (library (core alist) 2 | (export 3 | ref 4 | val 5 | alist->vector 6 | vector->alist) 7 | (import 8 | (scheme)) 9 | 10 | 11 | (define ref 12 | (lambda (str x) 13 | (if (null? str) 14 | '() 15 | (if (equal? (caar str) x) 16 | (cdar str) 17 | (ref (cdr str) x))))) 18 | 19 | 20 | (define val 21 | (lambda (str x) 22 | (if (null? str) 23 | '() 24 | (if (equal? (cdar str) x) 25 | (caar str) 26 | (val (cdr str) x))))) 27 | 28 | 29 | (define vector->alist 30 | (lambda (x) 31 | (let l ((x (vector->list x))(n 0)) 32 | (cons (cons n (car x)) 33 | (if (null? (cdr x)) 34 | '() 35 | (l (cdr x) (+ n 1))))))) 36 | 37 | 38 | (define alist->vector 39 | (lambda (x) 40 | (list->vector 41 | (let l ((x x)(n 0)) 42 | (cons (cdar x) 43 | (if (null? (cdr x)) 44 | '() 45 | (l (cdr x) (+ n 1)))))))) 46 | 47 | ) 48 | -------------------------------------------------------------------------------- /web/lib/core/exception.sc: -------------------------------------------------------------------------------- 1 | (library (core exception) 2 | (export 3 | try) 4 | (import 5 | (scheme)) 6 | 7 | 8 | (define-syntax try 9 | (syntax-rules (catch) 10 | ((_ body (catch catcher)) 11 | (call/cc 12 | (lambda (exit) 13 | (with-exception-handler 14 | (lambda (condition) 15 | (catcher condition) 16 | (exit condition)) 17 | (lambda () body))))))) 18 | 19 | ) 20 | -------------------------------------------------------------------------------- /web/lib/core/package.sc: -------------------------------------------------------------------------------- 1 | (("name" . "core") 2 | ("version" . "1.0.0") 3 | ("description" . "core") 4 | ("keywords" 5 | ("scheme" "core")) 6 | ("author" 7 | ("guenchi" "chclock")) 8 | ("private" . #f) 9 | ("scripts") 10 | ("dependencies") 11 | ("devDependencies")) 12 | -------------------------------------------------------------------------------- /web/lib/core/string.sc: -------------------------------------------------------------------------------- 1 | (library (core string) 2 | (export 3 | split) 4 | (import 5 | (scheme)) 6 | 7 | (define split 8 | (lambda (s c) 9 | (letrec* ((len (string-length s)) 10 | (walk (lambda (str begin end rst) 11 | (cond 12 | ((>= begin len) rst) 13 | ((or (= end len) (char=? (string-ref str end) c)) 14 | (walk 15 | str 16 | (+ end 1) 17 | (+ end 1) 18 | (if (= begin end) 19 | rst 20 | (cons (substring str begin end) rst)))) 21 | (else (walk str begin (+ end 1) rst)))))) 22 | (reverse (walk s 0 0 '()))))) 23 | 24 | 25 | ) 26 | -------------------------------------------------------------------------------- /web/lib/igropyr/LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright guenchi (c) 2018 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /web/lib/igropyr/README.md: -------------------------------------------------------------------------------- 1 | # Igropyr 2 | Cross platform async http-server for Chez Scheme 3 | 4 | How fast？ (test on single thread) 5 | ![image](https://github.com/guenchi/Igropyr/blob/master/benckmark.png?raw=true) 6 | (MacBook Pro Retina, High Sierra 10.13.3, Mid 2014 2.2 GHz Intel Core i7, 16 GB 1600 MHz DDR3) 7 | 8 | Chez Scheme run with the --script option and don't compile scheme code 9 | 10 | 11 | ***Igropyr : Node*** 12 | 13 | Scheme + ChezScheme + libuv : Javascript + V8 + libuv 14 | 15 | 16 | ***install Igropyr*** 17 | 18 | Igropyr dependence libuv, make sure you have installed it. 19 | 20 | then 21 | 22 | `$ cd igropyr/src && cc -fPIC -shared httpc.c membuf.c -luv -o ../httpc.so` 23 | 24 | or simply use Raven to install Igropyr: 25 | 26 | `$ raven install igropyr` 27 | 28 | 29 | ***start server:*** 30 | 31 | ``` 32 | (define get 33 | (lambda (header path query) 34 |     (response 200 "text/plain" "Hello World"))) 35 | 36 | (define post 37 | (lambda (header path payload) 38 |     (response 200 "text/plain" "Hello World"))) 39 | 40 | (server 41 | (request get) 42 | (request post) 43 | (set) 44 | (listen)) 45 | ``` 46 | 47 | 48 | (set) may define like: 49 | 50 | ``` 51 | (set 52 | ('staticpath "/usr/local/www") ;to define the static path 53 | ('connections 3600) ;to define the max connections, default is 1024 54 | ('keepalive 3600)) ;keepalive timeout, 0 for short connection, default is 5000 (ms) 55 | ``` 56 | 57 | (listen) may define like: 58 | 59 | ``` 60 | (listen "127.0.0.1" 8080) ;define the ip and port that server listen on 61 | (listen "127.0.0.1") ;if only define the ip, port use default 80 62 | (listen 8080) ;if only define the port, ip use default "0.0.0.0" 63 | ``` 64 | 65 | then 66 | 67 | ``` 68 | $ raven run example.sc 69 | ``` 70 | 71 | ***Igropyr's manuel***: https://guenchi.gitbooks.io/igropyr/ 72 | 73 | ***Raven***: Chez Scheme Package Manager http://ravensc.com 74 | 75 | ## Libraries may help: 76 | 77 | 78 | ***Ballista***: Webframework `raven install ballista` https://github.com/guenchi/Ballista (Express style) 79 | 80 | ***Catapult***: Webframework `raven install catapult` https://github.com/guenchi/Catapult (purely functional) 81 | 82 | ***JSON*** library `raven install json` https://github.com/guenchi/json 83 | 84 | ***JWT*** Json Web Token `raven install jwt` https://github.com/guenchi/jwt 85 | 86 | ***mySQL*** bingding `raven install mysql` https://github.com/chclock/mysql 87 | 88 | ***Liber***: HTML Template `raven install liber` https://github.com/guenchi/Liber 89 | 90 | 91 | ## todo list 92 | 93 | ``` 94 | https 95 | 96 | http/2.0 97 | 98 | connections limite 99 | 100 | long-connection 101 | ``` 102 | -------------------------------------------------------------------------------- /web/lib/igropyr/httpc.so: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/shenxs/about-scheme/7260128257b5b99fd516116de0387df92e2027e2/web/lib/igropyr/httpc.so -------------------------------------------------------------------------------- /web/lib/igropyr/package.sc: -------------------------------------------------------------------------------- 1 | (("name" . "igropyr") 2 | ("version" . "0.2.13") 3 | ("description" . "a async Scheme http server base on libuv") 4 | ("keywords" 5 | ("Scheme" "http-server" "async")) 6 | ("author" 7 | ("guenchi" "chclock")) 8 | ("private" . #f) 9 | ("scripts" 10 | ("build" . "cd ./lib/igropyr/src && cc -o3 -fPIC -shared httpc.c membuf.c -luv -o ../httpc.so") 11 | ("run" . "scheme --script") 12 | ("test" . "scheme --script server.sc")) 13 | ("dependencies" 14 | ("core" . "1.0.0")) 15 | ("devDependencies")) 16 | -------------------------------------------------------------------------------- /web/lib/igropyr/src/membuf.h: -------------------------------------------------------------------------------- 1 | #ifndef __MEMBUF_H__ 2 | #define __MEMBUF_H__ 3 | 4 | // `membuf_t` is a growable continuous in-memory buffer. 5 | // It also support "local buffer" to use stack memory efficiently. 6 | // https://github.com/liigo/membuf 7 | // by Liigo, 2013-7-5, 2014-8-16, 2014-10-21, 2014-11-18. 8 | 9 | #include 10 | 11 | typedef struct { 12 | unsigned char* data; 13 | unsigned int size; 14 | unsigned int buffer_size; 15 | unsigned char uses_local_buffer; // local buffer, e.g. on stack 16 | } membuf_t; 17 | 18 | #ifndef MEMBUF_INIT_LOCAL 19 | #define MEMBUF_INIT_LOCAL(buf,n) membuf_t buf; unsigned char buf##n[n]; membuf_init_local(&buf, &buf##n, n); 20 | #endif 21 | 22 | void membuf_init(membuf_t* buf, unsigned int initial_buffer_size); 23 | void membuf_init_local(membuf_t* buf, void* local_buffer, unsigned int local_buffer_size); 24 | void membuf_init_move_from(membuf_t* buf, membuf_t* other); // don't use other anymore 25 | void membuf_uninit(membuf_t* buf); 26 | 27 | unsigned int membuf_append_data(membuf_t* buf, void* data, unsigned int size); 28 | unsigned int membuf_append_zeros(membuf_t* buf, unsigned int size); 29 | unsigned int membuf_append_text(membuf_t* buf, const char* str, unsigned int len); 30 | unsigned int membuf_append_text_zero(membuf_t* buf, const char* str, unsigned int len); 31 | 32 | static void* membuf_get_data(membuf_t* buf) { return (buf->size == 0 ? NULL : buf->data); } 33 | static unsigned int membuf_get_size(membuf_t* buf) { return buf->size; } 34 | static unsigned int membuf_is_empty(membuf_t* buf) { return buf->size > 0; } 35 | static void membuf_empty(membuf_t* buf) { buf->size = 0; } 36 | 37 | void membuf_reserve(membuf_t* buf, unsigned int extra_size); 38 | void* membuf_detach(membuf_t* buf, unsigned int* psize); // need free() result if not NULL 39 | 40 | #if defined(_MSC_VER) 41 | #define MEMBUF_INLINE static _inline 42 | #else 43 | #define MEMBUF_INLINE static inline 44 | #endif 45 | 46 | MEMBUF_INLINE unsigned int membuf_append_byte(membuf_t* buf, unsigned char b) { 47 | return membuf_append_data(buf, &b, sizeof(b)); 48 | } 49 | MEMBUF_INLINE unsigned int membuf_append_int(membuf_t* buf, int i) { 50 | return membuf_append_data(buf, &i, sizeof(i)); 51 | } 52 | MEMBUF_INLINE unsigned int membuf_append_uint(membuf_t* buf, unsigned int ui) { 53 | return membuf_append_data(buf, &ui, sizeof(ui)); 54 | } 55 | MEMBUF_INLINE unsigned int membuf_append_short(membuf_t* buf, short s) { 56 | return membuf_append_data(buf, &s, sizeof(s)); 57 | } 58 | MEMBUF_INLINE unsigned int membuf_append_ushort(membuf_t* buf, unsigned short us) { 59 | return membuf_append_data(buf, &us, sizeof(us)); 60 | } 61 | MEMBUF_INLINE unsigned int membuf_append_float(membuf_t* buf, float f) { 62 | return membuf_append_data(buf, &f, sizeof(f)); 63 | } 64 | MEMBUF_INLINE unsigned int membuf_append_double(membuf_t* buf, double d) { 65 | return membuf_append_data(buf, &d, sizeof(d)); 66 | } 67 | MEMBUF_INLINE unsigned int membuf_append_ptr(membuf_t* buf, void* ptr) { 68 | return membuf_append_data(buf, &ptr, sizeof(ptr)); 69 | } 70 | 71 | #endif //__MEMBUF_H__ 72 | -------------------------------------------------------------------------------- /web/main.ss: -------------------------------------------------------------------------------- 1 | (import (igropyr http)) 2 | 3 | (define (logger in) 4 | (display in)) 5 | 6 | (define (main-page) 7 | " 8 | 9 | 10 |
11 |

hello

12 |

13 | this is a try 14 |

15 |
16 | ") 17 | 18 | (define get 19 | (lambda (header path query) 20 | ;; (logger (list header path query)) 21 | (sendfile "" "index.html") 22 | ) 23 | ) 24 | 25 | (define post 26 | (lambda (header path payload) 27 | (response 200 "text/plain" "Hello from post"))) 28 | 29 | (define fib 30 | (lambda x 31 | ((cond 32 | ([= x 1] 1) 33 | (else (* x (fib (- x 1)))))))) 34 | 35 | 36 | (server 37 | (request get) 38 | (request post) 39 | (set 40 | ('staticpath "./") ;to define the static path 41 | ('connections 3600) ;to define the max connections, default is 1024 42 | ('keepalive 3600)) 43 | (listen 8080)) 44 | 45 | -------------------------------------------------------------------------------- /web/package.sc: -------------------------------------------------------------------------------- 1 | (("name" . "") 2 | ("version" . "") 3 | ("description" . "") 4 | ("keywords") 5 | ("author" 6 | ("richard")) 7 | ("private" . #f) 8 | ("scripts" 9 | ("repl" . "scheme") 10 | ("run" . "scheme --script")) 11 | ("dependencies" 12 | ("igropyr" . "0.2.13")) 13 | ("devDependencies")) 14 | --------------------------------------------------------------------------------