(load "list-procedures.ss") (require (lib "trace.ss")) (define (pick-better cf p1 p2) (if (cf p1 p2) p1 p2)) (define (list-find-best cf p) (if (null? (cdr p)) (car p) (pick-better cf (car p) (list-find-best cf (cdr p))))) (define (list-delete p el) (if (null? p) null (if (equal? (car p) el) ; found match, delete this element (cdr p) (cons (car p) (list-delete (cdr p) el))))) (define (list-sort-best-first cf p) (if (null? p) null (cons (list-find-best cf p) (list-sort-best-first cf (list-delete p (list-find-best cf p)))))) (define (list-sort-best-first-nodup cf p) (if (null? p) null ((lambda (best) (cons best (list-sort-best-first-nodup cf (list-delete p best)))) (list-find-best cf p)))) (define (list-sort-best-first-let cf p) (if (null? p) null (let ((best (list-find-best cf p))) (cons best (list-sort-best-first-let cf (list-delete p best)))))) (define (list-insert-one cf el p) ; pre: p must be in sorted order by cf (if (null? p) (list el) (if (cf el (car p)) (cons el p) (cons (car p) (list-insert-one cf el (cdr p)))))) (define (list-sort-insert cf p) (if (null? p) null (list-insert-one cf (car p) (list-sort-insert cf (cdr p))))) (define (make-random-list n max) (if (= n 0) null (cons (random max) (make-random-list (- n 1) max)))) ;;; quicksort (define (list-extract p start end) (if (= start 0) (if (= end 0) null (cons (car p) (list-extract (cdr p) start (- end 1)))) (list-extract (cdr p) (- start 1) (- end 1)))) (define (list-first-half p) (list-extract p 0 (floor (/ (list-length p) 2)))) (define (list-second-half p) (list-extract p (floor (/ (list-length p) 2)) (list-length p))) (define (list-insert-one-halves cf el p) (if (null? p) (list el) (if (null? (cdr p)) (if (cf el (car p)) (cons el p) (list (car p) el)) (let ((front (list-first-half p)) (back (list-second-half p))) (if (cf el (car back)) (list-append (list-insert-one-halves cf el front) back) (list-append front (list-insert-one-halves cf el back))))))) (define (list-sort-insert-halves cf p) (if (null? p) null (list-insert-one-halves cf (car p) (list-sort-insert-halves cf (cdr p))))) ;;; ;;; Binary Trees ;;; (define (make-tree left element right) (cons element (cons left right))) (define (tree-element tree) (car tree)) (define (tree-left tree) (car (cdr tree))) (define (tree-right tree) (cdr (cdr tree))) (define (tree-insert-one cf el tree) (if (null? tree) (make-tree null el null) (if (cf el (tree-element tree)) (make-tree (tree-insert-one cf el (tree-left tree)) (tree-element tree) (tree-right tree)) (make-tree (tree-left tree) (tree-element tree) (tree-insert-one cf el (tree-right tree)))))) (define (tree-extract-elements tree) (if (null? tree) null (list-append (tree-extract-elements (tree-left tree)) (cons (tree-element tree) (tree-extract-elements (tree-right tree)))))) (define (list-to-sorted-tree cf p) (if (null? p) null (tree-insert-one cf (car p) (list-to-sorted-tree cf (cdr p))))) (define (list-sort-tree cf p) (tree-extract-elements (list-to-sorted-tree cf p))) ;;; ;;; Quicksort ;;; (define (list-quicksort cf p) (if (null? p) null (list-append (list-quicksort cf (list-filter (lambda (el) (cf el (car p))) (cdr p))) (cons (car p) (list-quicksort cf (list-filter (lambda (el) (not (cf el (car p)))) (cdr p))))))) (define list1 (make-random-list 1000 1000)) (define list2 (make-random-list 2000 1000)) ;;; ;;; Searching ;;; ;;; ;;; Unstructured Sorting ;;; (define (list-search ef p) (if (null? p) false ; Not found (if (ef (car p)) (car p) (list-search ef (cdr p))))) ;;; ;;; Binary Search ;;; (define (binary-tree-search ef cf tree) (if (null? tree) false (if (ef (tree-element tree)) (tree-element tree) (if (cf (tree-element tree)) (binary-tree-search ef cf (tree-left tree)) (binary-tree-search ef cf (tree-right tree)))))) (define (binary-tree-has-number btree target) (if (binary-tree-search (lambda (el) (= target el)) (lambda (el) (< target el)) btree) true false)) ;;; ;;; Indexed Searching ;;; ;; divide a string into a list of (word pos) pairs (define (text-to-word-positions s) (define (text-to-word-positions-iter p w pos) (if (null? p) (if (null? w) null (list (cons (list->string w) pos))) (if (not (char-alphabetic? (car p))) ; finished word (if (null? w) ; no current word (text-to-word-positions-iter (cdr p) null (+ pos 1)) (cons (cons (list->string w) pos) (text-to-word-positions-iter (cdr p) null (+ pos (list-length w) 1)))) (text-to-word-positions-iter (cdr p) (list-append w (list (char-downcase (car p)))) pos)))) (text-to-word-positions-iter (string->list s) null 0)) (define (insert-into-index index wp) (if (null? index) (make-tree null (cons (car wp) (list (cdr wp))) null) (if (string=? (car wp) (car (tree-element index))) (make-tree (tree-left index) (cons (car (tree-element index)) (list-append (cdr (tree-element index)) (list (cdr wp)))) (tree-right index)) (if (stringstring (read-all-chars (get-pure-port (string->url url))))) (define (tree-size tree) (if (null? tree) 0 (+ 1 (tree-size (tree-left tree)) (tree-size (tree-right tree))))) (define (merge-indexes d1 d2) (define (merge-elements p1 p2) (if (null? p1) p2 (if (null? p2) p1 (if (string=? (car (car p1)) (car (car p2))) (cons (cons (car (car p1)) (list-append (cdr (car p1)) (cdr (car p2)))) (merge-elements (cdr p1) (cdr p2))) (if (string ;;; Tragedies "cleopatra" ; Antony and Cleopatra "coriolanus" ; Coriolanus "hamlet" ; Hamlet "julius_caesar" ; Julius Caesar "lear" ; King Lear "macbeth" ; Macbeth "othello" ; Othello "romeo_juliet" ; Romeo and Juliet "timon" ; Timon of Athens "titus" ; Titus Andronicus )))) ;; (define shakespeare-index (time (make-bills-index))) (define (search-in-index index word) (binary-tree-search (lambda (el) (string=? word (car el))) (lambda (el) (string (cdr e1) (cdr e2))) (list-map (lambda (el) (cons (car el) (length (cdr el)))) (tree-extract-elements index))))