jellyr · May 9, 2017 13:17 · Jan 16, 2014
diff --git a/functional.rkt b/functional.rkt
@@ -0,0 +1,219 @@
+#lang racket
+(require rackunit)
+
+;; A singly linked list is either
+;; - NULL
+;; - pointer to data and a pointer a sll
+(struct node (data-ptr next-ptr))
+
+(define n4 (node 4 null))
+
+;; n4->data-ptr
+(check-equal? (node-data-ptr n4) 4)
+
+(define n54 (node 5 n4))
+
+;; n54->next-ptr->data-ptr
+(check-equal? (node-data-ptr (node-next-ptr n54)) 4)
+
+;; A list is either
+;; - null
+;; - (cons data list)
+
+(define c4 (cons 4 null))
+(define c54 (cons 5 c4))
+
+(check-equal? (car (cdr c54)) 4)
+
+;; c[ad]+r
+
+(check-equal? (cadr c54) 4)
+
+(check-equal? (first (rest c54)) 4)
+(check-equal? (second c54) 4)
+
+;; length : list(a) -> num
+;; (length l) = 42
+(define (length l)
+  (if (cons? l)
+      (+ 1 (length (rest l)))
+      0))
+
+;; f(x) = x + 4
+;; f(5) = 5 + 4
+
+(check-equal? (length c54) 2)
+(check-equal? (length null) 0)
+(check-equal? (length c4) 1)
+
+;; expression problem
+;; fun = easy to add functions
+;; oo = easy to add kinds
+
+;; all-even? : list num -> bool
+(define (all-even? l)
+  (if (empty? l)
+      true
+      (and (even? (first l))
+           (all-even? (rest l)))))
+
+(check-equal? (all-even? null) true)
+(check-equal? (all-even? (list 1 2 3)) false)
+(check-equal? (all-even? (list 2 4 6)) true)
+
+;; higher-order function
+
+(check-equal? (all-even? (list 2 4 6))
+              (all-even? (cons 2 (list 4 6))))
+(check-equal? (all-even? (cons 2 (list 4 6)))
+              (and (even? (first (cons 2 (list 4 6))))
+                   (all-even? (rest (cons 2 (list 4 6))))))
+(check-equal? (all-even? (cons 2 (list 4 6)))
+              (and (even? 2)
+                   (all-even? (list 4 6))))
+(check-equal? (all-even? 
+               (cons 2 
+                     (cons 4 
+                           (cons 6
+                                 empty))))
+              (and (even? 2)
+                   (and (even? 4)
+                        (and (even? 6)
+                             true))))
+;; all-even?s job is to...
+;; turn empty into true
+;; turn (cons a r) into (and (even? a) r)
+;; greek name for this: catamorphism
+
+(define (all-even?/awesome l)
+  (foldr (lambda (a d) 
+           (and (even? a) d))
+         true
+         l))
+
+(check-equal? (all-even?/awesome null) true)
+(check-equal? (all-even?/awesome (list 1 2 3)) false)
+(check-equal? (all-even?/awesome (list 2 4 6)) true)
+
+;; foldr : (A B -> B) B (list A) -> B
+
+;; int f ( int x, int y ) { ... }
+;; int int -> int
+
+(define (sum l)
+  ;; + : (A B -> B) : (nat nat -> nat)
+  ;; 0 : B : nat
+  ;; l : (list A) : (list nat)
+  (foldr + 0 l))
+
+(define arithmetic (list + - * /))
+
+(check-equal? (sum (list 1 2 3 4)) 10)
+
+;; map : (A -> B) (list A) -> (list B)
+
+(define (evenify l)
+  (map even? l))
+
+(check-equal? (evenify (list 1 2 3 4))
+              (list false true false true))
+
+;; A bt is either a 
+(struct bt-leaf () #:transparent)
+(struct bt-node (left val right)  #:transparent)
+
+;; these are all (bt num)
+(define b5 (bt-node (bt-leaf) 5 (bt-leaf)))
+(define b6 (bt-node b5 6 (bt-leaf)))
+(define bb (bt-node (bt-node (bt-leaf) 3 (bt-leaf))
+                    4
+                    b6))
+
+;; lookup : (bt A) A -> bool 
+(define (lookup bt v)
+  (cond
+    [(bt-leaf? bt)
+     false]
+    [else
+     (cond
+       [(= v (bt-node-val bt))
+        true]
+       [(< v (bt-node-val bt))
+        (lookup (bt-node-left bt) v)]
+       [else
+        (lookup (bt-node-right bt) v)])]))
+
+(check-equal? (lookup bb 5) true)
+(check-equal? (lookup bb 2) false)
+
+;; insert : (bt A) A -> (bt A)
+(define (insert bt v)
+  (cond
+    [(bt-leaf? bt)
+     (bt-node (bt-leaf) v (bt-leaf))]
+    [else
+     (cond
+       [(= v (bt-node-val bt))
+        bt]
+       [(< v (bt-node-val bt))
+        (bt-node (insert (bt-node-left bt) v)
+                 (bt-node-val bt)
+                 (bt-node-right bt))]
+       [else
+        (bt-node 
+         (bt-node-left bt)
+         (bt-node-val bt)
+         (insert (bt-node-right bt) v))])]))
+
+;; lg n in time
+;; lg n in space
+
+(check-equal? (lookup bb 2) false)
+(check-equal? (lookup (insert bb 2) 2) true)
+(check-equal? (lookup bb 2) false)
+
+(struct zipper (path focus))
+(struct path-tree-left (val right))
+(struct path-tree-right (left val))
+
+(define bbz (zipper empty bb))
+
+(define (move-left z)
+  (match-define (zipper path focus) z)
+  (match focus
+    [(bt-leaf)
+     (error 'move-left "Can't")]
+    [(bt-node left val right)
+     (zipper (cons (path-tree-left val right)
+                   path)
+             left)]))
+
+(define (move-right z)
+  (match-define (zipper path focus) z)
+  (match focus
+    [(bt-leaf)
+     (error 'move-left "Can't")]
+    [(bt-node left val right)
+     (zipper (cons (path-tree-right left val)
+                   path)
+             right)]))
+
+(define (move-up z)
+  (match-define (zipper path focus) z)
+  (match path
+    [(list)
+     (error 'move-up "Can't")]
+    [(cons (path-tree-left val right) old-path)
+     (zipper old-path (bt-node focus val right))]
+    [(cons (path-tree-right left val) old-path)
+     (zipper old-path (bt-node left val focus))]))
+
+(define (replace z v)
+  (match-define (zipper path focus) z)
+  (zipper path v))
+
+(zipper-focus
+ (move-up
+  (move-up
+   (replace (move-right (move-left bbz))
+            (bt-node (bt-leaf) 3.5 (bt-leaf))))))
diff --git a/page.rkt b/page.rkt
@@ -0,0 +1,8 @@
+#lang s-exp "web.rkt"
+
+(div ([style "color: blue"])
+     (a ([href "http://racket-lang.org"]
+         [style "font-weight: bold"])
+        "Hello " 
+        "world")
+     " bye")
diff --git a/web.rkt b/web.rkt
@@ -0,0 +1,45 @@
+#lang racket
+(require web-server/servlet-env
+         web-server/http/xexpr
+         (for-syntax syntax/parse))
+
+(provide (except-out (all-from-out racket)
+                     #%module-begin)
+         (rename-out [module-begin #%module-begin]))
+
+(define-syntax-rule (module-begin expr)
+  (#%module-begin (page expr)))
+
+(define (show v)
+  (print v)
+  (newline)
+  v)
+
+(define-syntax define-tag
+  (lambda (stx)
+    (syntax-parse stx
+      [(define-tag tag ok-attrib ...)
+       #'(begin
+           (define-syntax tag
+             (lambda (stx)
+               (syntax-parse stx
+                 [(tag ([attrib s-expr] (... ...)) content-expr (... ...))
+                  (unless (ormap (lambda (a) (member (syntax-e a)
+                                                     '(ok-attrib ...)))
+                                 (syntax-e #'(attrib (... ...))))
+                    (raise-syntax-error #f "bad attribute" stx))
+                  #'(show
+                     `(tag ([attrib ,s-expr] (... ...))
+                           ,content-expr (... ...)))])))
+           (provide tag))])))
+
+(define-tag div style)
+(define-tag a href style)
+
+(define (page content)
+  (serve/servlet
+   (lambda (req)
+     (response/xexpr
+      content))))
+
+(provide page)
No results found