Programs by Jay and Matthew at Lambda Lounge Utah, 14 Jan 2014: * "functional.rkt" is from Jay's introduction to functional programming * "web.rkt" and "page.rkt" are from Matthew's explanation of Racket macros & modules

functional.rkt

#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))))))

page.rkt

#lang s-exp "web.rkt"

(div ([style "color: blue"])
     (a ([href "http://racket-lang.org"]
         [style "font-weight: bold"])
        "Hello " 
        "world")
     " bye")

web.rkt

#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)