Add diff, ring buffer, printf, heap, and LRU cache modules
ober
2aeccfb1bfb9c68d8bd2cfce87268449aba24dd6
new file mode 100644 --- /dev/null +++ b/lib/std/misc/heap.sls @@ -0,0 +1,158 @@ +#!chezscheme +;;; (std misc heap) -- Priority Queue / Binary Heap +;;; +;;; Min-heap by default. Use custom comparator for max-heap. +;;; +;;; Usage: +;;; (import (std misc heap)) +;;; (define h (make-heap <)) ;; min-heap +;;; (heap-insert! h 5) +;;; (heap-insert! h 2) +;;; (heap-insert! h 8) +;;; (heap-peek h) ; => 2 +;;; (heap-extract! h) ; => 2 +;;; (heap-peek h) ; => 5 +;;; +;;; ;; Max-heap +;;; (define mh (make-heap >)) +;;; +;;; ;; Heapify +;;; (define h2 (list->heap < '(5 3 1 4 2))) +;;; (heap->sorted-list h2) ; => (1 2 3 4 5) + +(library (std misc heap) + (export + make-heap + heap? + heap-size + heap-empty? + heap-insert! + heap-peek + heap-extract! + heap-clear! + list->heap + heap->list + heap->sorted-list) + + (import (chezscheme)) + + (define-record-type heap-rec + (fields (immutable cmp) ;; comparator: (lambda (a b) -> bool) = "a has higher priority" + (mutable data) ;; vector + (mutable count) ;; current element count + (mutable capacity)) ;; vector length + (protocol (lambda (new) + (lambda (cmp) + (new cmp (make-vector 16 #f) 0 16))))) + + (define (make-heap cmp) (make-heap-rec cmp)) + (define (heap? x) (heap-rec? x)) + (define (heap-size h) (heap-rec-count h)) + (define (heap-empty? h) (= (heap-rec-count h) 0)) + + ;; ========== Insert ========== + (define (heap-insert! h val) + ;; Grow if needed + (when (= (heap-rec-count h) (heap-rec-capacity h)) + (grow! h)) + (let ([i (heap-rec-count h)]) + (vector-set! (heap-rec-data h) i val) + (heap-rec-count-set! h (+ i 1)) + (bubble-up! h i))) + + ;; ========== Peek ========== + (define (heap-peek h) + (when (heap-empty? h) + (error 'heap-peek "heap is empty")) + (vector-ref (heap-rec-data h) 0)) + + ;; ========== Extract ========== + (define (heap-extract! h) + (when (heap-empty? h) + (error 'heap-extract! "heap is empty")) + (let* ([data (heap-rec-data h)] + [top (vector-ref data 0)] + [last-idx (- (heap-rec-count h) 1)]) + (vector-set! data 0 (vector-ref data last-idx)) + (vector-set! data last-idx #f) + (heap-rec-count-set! h last-idx) + (when (> last-idx 0) + (bubble-down! h 0)) + top)) + + ;; ========== Clear ========== + (define (heap-clear! h) + (heap-rec-data-set! h (make-vector 16 #f)) + (heap-rec-count-set! h 0) + (heap-rec-capacity-set! h 16)) + + ;; ========== Conversions ========== + (define (list->heap cmp lst) + (let ([h (make-heap cmp)]) + (for-each (lambda (x) (heap-insert! h x)) lst) + h)) + + (define (heap->list h) + ;; Return elements in internal order (not sorted) + (let ([data (heap-rec-data h)] + [n (heap-rec-count h)]) + (let loop ([i 0] [acc '()]) + (if (= i n) (reverse acc) + (loop (+ i 1) (cons (vector-ref data i) acc)))))) + + (define (heap->sorted-list h) + ;; Extract all in priority order (destructive!) + (let loop ([acc '()]) + (if (heap-empty? h) + (reverse acc) + (loop (cons (heap-extract! h) acc))))) + + ;; ========== Internal ========== + (define (heap-parent i) (quotient (- i 1) 2)) + (define (left i) (+ (* 2 i) 1)) + (define (right i) (+ (* 2 i) 2)) + + (define (bubble-up! h i) + (let ([data (heap-rec-data h)] + [cmp (heap-rec-cmp h)]) + (let loop ([i i]) + (when (> i 0) + (let ([p (heap-parent i)]) + (when (cmp (vector-ref data i) (vector-ref data p)) + (swap! data i p) + (loop p))))))) + + (define (bubble-down! h i) + (let ([data (heap-rec-data h)] + [cmp (heap-rec-cmp h)] + [n (heap-rec-count h)]) + (let loop ([i i]) + (let ([l (left i)] + [r (right i)] + [best i]) + (when (and (< l n) (cmp (vector-ref data l) (vector-ref data best))) + (set! best l)) + (when (and (< r n) (cmp (vector-ref data r) (vector-ref data best))) + (set! best r)) + (unless (= best i) + (swap! data i best) + (loop best)))))) + + (define (swap! vec i j) + (let ([tmp (vector-ref vec i)]) + (vector-set! vec i (vector-ref vec j)) + (vector-set! vec j tmp))) + + (define (grow! h) + (let* ([old (heap-rec-data h)] + [old-cap (heap-rec-capacity h)] + [new-cap (* old-cap 2)] + [new-vec (make-vector new-cap #f)]) + (let loop ([i 0]) + (when (< i old-cap) + (vector-set! new-vec i (vector-ref old i)) + (loop (+ i 1)))) + (heap-rec-data-set! h new-vec) + (heap-rec-capacity-set! h new-cap))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/lru-cache.sls @@ -0,0 +1,178 @@ +#!chezscheme +;;; (std misc lru-cache) -- LRU Cache with O(1) Operations +;;; +;;; Standalone LRU cache using hash table + doubly-linked list. +;;; O(1) get, put, and eviction. +;;; +;;; Usage: +;;; (import (std misc lru-cache)) +;;; (define cache (make-lru-cache 100)) +;;; (lru-cache-put! cache "key1" "value1") +;;; (lru-cache-get cache "key1") ; => "value1" +;;; (lru-cache-get cache "missing" #f) ; => #f +;;; +;;; (lru-cache-stats cache) ; => ((size . N) (capacity . M) (hits . H) (misses . M)) + +(library (std misc lru-cache) + (export + make-lru-cache + lru-cache? + lru-cache-get + lru-cache-put! + lru-cache-delete! + lru-cache-contains? + lru-cache-size + lru-cache-capacity + lru-cache-clear! + lru-cache-keys + lru-cache-values + lru-cache-stats + lru-cache-for-each) + + (import (chezscheme)) + + ;; ========== Doubly-linked list node ========== + (define-record-type node-rec + (fields (immutable key) + (mutable value) + (mutable prev) + (mutable next)) + (protocol (lambda (new) + (lambda (key value) + (new key value #f #f))))) + + ;; ========== LRU Cache ========== + (define-record-type lru-cache-rec + (fields (immutable capacity) + (immutable table) ;; hashtable: key -> node + (mutable head) ;; most recently used + (mutable tail) ;; least recently used + (mutable size) + (mutable hits) + (mutable misses)) + (protocol (lambda (new) + (lambda (cap) + (new cap (make-hashtable equal-hash equal?) #f #f 0 0 0))))) + + (define (make-lru-cache cap) + (unless (> cap 0) (error 'make-lru-cache "capacity must be positive" cap)) + (make-lru-cache-rec cap)) + + (define (lru-cache? x) (lru-cache-rec? x)) + (define (lru-cache-size c) (lru-cache-rec-size c)) + (define (lru-cache-capacity c) (lru-cache-rec-capacity c)) + + ;; ========== Get ========== + (define lru-cache-get + (case-lambda + [(c key) (lru-cache-get c key (void))] + [(c key default) + (let ([node (hashtable-ref (lru-cache-rec-table c) key #f)]) + (if node + (begin + (lru-cache-rec-hits-set! c (+ (lru-cache-rec-hits c) 1)) + (move-to-head! c node) + (node-rec-value node)) + (begin + (lru-cache-rec-misses-set! c (+ (lru-cache-rec-misses c) 1)) + default)))])) + + ;; ========== Put ========== + (define (lru-cache-put! c key value) + (let ([existing (hashtable-ref (lru-cache-rec-table c) key #f)]) + (if existing + ;; Update existing + (begin + (node-rec-value-set! existing value) + (move-to-head! c existing)) + ;; Insert new + (begin + (when (= (lru-cache-rec-size c) (lru-cache-rec-capacity c)) + (evict-tail! c)) + (let ([node (make-node-rec key value)]) + (hashtable-set! (lru-cache-rec-table c) key node) + (lru-cache-rec-size-set! c (+ (lru-cache-rec-size c) 1)) + (add-to-head! c node)))))) + + ;; ========== Delete ========== + (define (lru-cache-delete! c key) + (let ([node (hashtable-ref (lru-cache-rec-table c) key #f)]) + (when node + (remove-node! c node) + (hashtable-delete! (lru-cache-rec-table c) key) + (lru-cache-rec-size-set! c (- (lru-cache-rec-size c) 1))))) + + ;; ========== Contains ========== + (define (lru-cache-contains? c key) + (hashtable-contains? (lru-cache-rec-table c) key)) + + ;; ========== Clear ========== + (define (lru-cache-clear! c) + (hashtable-clear! (lru-cache-rec-table c)) + (lru-cache-rec-head-set! c #f) + (lru-cache-rec-tail-set! c #f) + (lru-cache-rec-size-set! c 0)) + + ;; ========== Keys/Values ========== + (define (lru-cache-keys c) + ;; MRU to LRU order + (let loop ([node (lru-cache-rec-head c)] [acc '()]) + (if (not node) (reverse acc) + (loop (node-rec-next node) (cons (node-rec-key node) acc))))) + + (define (lru-cache-values c) + (let loop ([node (lru-cache-rec-head c)] [acc '()]) + (if (not node) (reverse acc) + (loop (node-rec-next node) (cons (node-rec-value node) acc))))) + + ;; ========== Stats ========== + (define (lru-cache-stats c) + `((size . ,(lru-cache-rec-size c)) + (capacity . ,(lru-cache-rec-capacity c)) + (hits . ,(lru-cache-rec-hits c)) + (misses . ,(lru-cache-rec-misses c)) + (hit-rate . ,(let ([total (+ (lru-cache-rec-hits c) (lru-cache-rec-misses c))]) + (if (= total 0) 0.0 + (inexact (/ (lru-cache-rec-hits c) total))))))) + + ;; ========== Iteration ========== + (define (lru-cache-for-each proc c) + ;; Calls (proc key value) for each entry, MRU to LRU + (let loop ([node (lru-cache-rec-head c)]) + (when node + (proc (node-rec-key node) (node-rec-value node)) + (loop (node-rec-next node))))) + + ;; ========== Internal Linked List Operations ========== + (define (add-to-head! c node) + (node-rec-prev-set! node #f) + (node-rec-next-set! node (lru-cache-rec-head c)) + (when (lru-cache-rec-head c) + (node-rec-prev-set! (lru-cache-rec-head c) node)) + (lru-cache-rec-head-set! c node) + (unless (lru-cache-rec-tail c) + (lru-cache-rec-tail-set! c node))) + + (define (remove-node! c node) + (let ([prev (node-rec-prev node)] + [next (node-rec-next node)]) + (if prev + (node-rec-next-set! prev next) + (lru-cache-rec-head-set! c next)) + (if next + (node-rec-prev-set! next prev) + (lru-cache-rec-tail-set! c prev)))) + + (define (move-to-head! c node) + (unless (eq? node (lru-cache-rec-head c)) + (remove-node! c node) + (add-to-head! c node))) + + (define (evict-tail! c) + (let ([tail (lru-cache-rec-tail c)]) + (when tail + (hashtable-delete! (lru-cache-rec-table c) (node-rec-key tail)) + (remove-node! c tail) + (lru-cache-rec-size-set! c (- (lru-cache-rec-size c) 1))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/ringbuf.sls @@ -0,0 +1,131 @@ +#!chezscheme +;;; (std misc ringbuf) -- Ring Buffer / Circular Buffer +;;; +;;; Fixed-size circular buffer with O(1) push/pop operations. +;;; When full, new elements overwrite the oldest. +;;; +;;; Usage: +;;; (import (std misc ringbuf)) +;;; (define rb (make-ringbuf 5)) +;;; (ringbuf-push! rb 1) +;;; (ringbuf-push! rb 2) +;;; (ringbuf-push! rb 3) +;;; (ringbuf->list rb) ; => (1 2 3) +;;; (ringbuf-peek rb) ; => 1 (oldest) +;;; (ringbuf-pop! rb) ; => 1 +;;; ;; When full, overwrites oldest +;;; (ringbuf-full? rb) + +(library (std misc ringbuf) + (export + make-ringbuf + ringbuf? + ringbuf-capacity + ringbuf-size + ringbuf-empty? + ringbuf-full? + ringbuf-push! + ringbuf-pop! + ringbuf-peek + ringbuf-peek-newest + ringbuf-clear! + ringbuf->list + ringbuf-for-each + ringbuf-ref) + + (import (chezscheme)) + + (define-record-type ringbuf-rec + (fields (immutable capacity) + (immutable buf) ;; vector + (mutable head) ;; read position + (mutable tail) ;; write position + (mutable count)) ;; current count + (protocol (lambda (new) + (lambda (cap) + (new cap (make-vector cap #f) 0 0 0))))) + + (define (make-ringbuf cap) + (unless (> cap 0) (error 'make-ringbuf "capacity must be positive" cap)) + (make-ringbuf-rec cap)) + + (define (ringbuf? x) (ringbuf-rec? x)) + (define (ringbuf-capacity rb) (ringbuf-rec-capacity rb)) + (define (ringbuf-size rb) (ringbuf-rec-count rb)) + (define (ringbuf-empty? rb) (= (ringbuf-rec-count rb) 0)) + (define (ringbuf-full? rb) (= (ringbuf-rec-count rb) (ringbuf-rec-capacity rb))) + + (define (ringbuf-push! rb val) + ;; Push value. If full, overwrites oldest (advances head). + (let ([buf (ringbuf-rec-buf rb)] + [tail (ringbuf-rec-tail rb)] + [cap (ringbuf-rec-capacity rb)]) + (vector-set! buf tail val) + (ringbuf-rec-tail-set! rb (modulo (+ tail 1) cap)) + (if (ringbuf-full? rb) + ;; Overwrite: advance head + (ringbuf-rec-head-set! rb (modulo (+ (ringbuf-rec-head rb) 1) cap)) + ;; Not full: increment count + (ringbuf-rec-count-set! rb (+ (ringbuf-rec-count rb) 1))))) + + (define (ringbuf-pop! rb) + ;; Pop oldest value + (when (ringbuf-empty? rb) + (error 'ringbuf-pop! "ring buffer is empty")) + (let* ([buf (ringbuf-rec-buf rb)] + [head (ringbuf-rec-head rb)] + [val (vector-ref buf head)]) + (vector-set! buf head #f) ;; help GC + (ringbuf-rec-head-set! rb (modulo (+ head 1) (ringbuf-rec-capacity rb))) + (ringbuf-rec-count-set! rb (- (ringbuf-rec-count rb) 1)) + val)) + + (define (ringbuf-peek rb) + ;; Look at oldest without removing + (when (ringbuf-empty? rb) + (error 'ringbuf-peek "ring buffer is empty")) + (vector-ref (ringbuf-rec-buf rb) (ringbuf-rec-head rb))) + + (define (ringbuf-peek-newest rb) + ;; Look at newest element + (when (ringbuf-empty? rb) + (error 'ringbuf-peek-newest "ring buffer is empty")) + (let ([idx (modulo (- (ringbuf-rec-tail rb) 1) (ringbuf-rec-capacity rb))]) + (vector-ref (ringbuf-rec-buf rb) idx))) + + (define (ringbuf-ref rb i) + ;; Access i-th element (0 = oldest) + (when (or (< i 0) (>= i (ringbuf-rec-count rb))) + (error 'ringbuf-ref "index out of range" i)) + (let ([idx (modulo (+ (ringbuf-rec-head rb) i) (ringbuf-rec-capacity rb))]) + (vector-ref (ringbuf-rec-buf rb) idx))) + + (define (ringbuf-clear! rb) + (let ([buf (ringbuf-rec-buf rb)] + [cap (ringbuf-rec-capacity rb)]) + (let loop ([i 0]) + (when (< i cap) + (vector-set! buf i #f) + (loop (+ i 1)))) + (ringbuf-rec-head-set! rb 0) + (ringbuf-rec-tail-set! rb 0) + (ringbuf-rec-count-set! rb 0))) + + (define (ringbuf->list rb) + ;; Return elements in order (oldest to newest) + (let loop ([i 0] [acc '()]) + (if (= i (ringbuf-rec-count rb)) + (reverse acc) + (loop (+ i 1) (cons (ringbuf-ref rb i) acc))))) + + (define (ringbuf-for-each proc rb) + (let ([count (ringbuf-rec-count rb)] + [head (ringbuf-rec-head rb)] + [cap (ringbuf-rec-capacity rb)] + [buf (ringbuf-rec-buf rb)]) + (let loop ([i 0]) + (when (< i count) + (proc (vector-ref buf (modulo (+ head i) cap))) + (loop (+ i 1)))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/text/diff.sls @@ -0,0 +1,168 @@ +#!chezscheme +;;; (std text diff) -- Text Diffing Utilities +;;; +;;; Line-by-line diff with unified diff output format. +;;; +;;; Usage: +;;; (import (std text diff)) +;;; (diff-lines '("a" "b" "c") '("a" "x" "c")) +;;; ; => ((keep "a") (remove "b") (add "x") (keep "c")) +;;; +;;; (diff-unified "file1" "file2" +;;; '("a" "b" "c") '("a" "x" "c")) +;;; ; => unified diff string +;;; +;;; (edit-distance "kitten" "sitting") ; => 3 + +(library (std text diff) + (export + diff-lines + diff-unified + diff-strings + edit-distance + diff-summary + diff-apply) + + (import (chezscheme)) + + ;; ========== LCS-based Line Diff ========== + ;; Uses Hunt-McIlroy / simple O(nm) DP for correctness + + (define (diff-lines old new) + ;; Returns list of (keep str) | (remove str) | (add str) + (let* ([old-v (list->vector old)] + [new-v (list->vector new)] + [m (vector-length old-v)] + [n (vector-length new-v)] + ;; DP table for LCS length + [dp (make-vector (* (+ m 1) (+ n 1)) 0)]) + + ;; Fill DP table + (let loop-i ([i 1]) + (when (<= i m) + (let loop-j ([j 1]) + (when (<= j n) + (if (string=? (vector-ref old-v (- i 1)) + (vector-ref new-v (- j 1))) + (dp-set! dp m n i j (+ 1 (dp-ref dp m n (- i 1) (- j 1)))) + (dp-set! dp m n i j (max (dp-ref dp m n (- i 1) j) + (dp-ref dp m n i (- j 1))))) + (loop-j (+ j 1)))) + (loop-i (+ i 1)))) + + ;; Backtrace + (let backtrace ([i m] [j n] [result '()]) + (cond + [(and (= i 0) (= j 0)) result] + [(and (> i 0) (> j 0) + (string=? (vector-ref old-v (- i 1)) + (vector-ref new-v (- j 1)))) + (backtrace (- i 1) (- j 1) + (cons (list 'keep (vector-ref old-v (- i 1))) result))] + [(and (> j 0) + (or (= i 0) + (> (dp-ref dp m n i (- j 1)) + (dp-ref dp m n (- i 1) j)))) + (backtrace i (- j 1) + (cons (list 'add (vector-ref new-v (- j 1))) result))] + [else + (backtrace (- i 1) j + (cons (list 'remove (vector-ref old-v (- i 1))) result))])))) + + (define (dp-ref dp m n i j) + (vector-ref dp (+ (* i (+ n 1)) j))) + + (define (dp-set! dp m n i j val) + (vector-set! dp (+ (* i (+ n 1)) j) val)) + + ;; ========== Unified Diff ========== + (define (diff-unified name1 name2 old new) + ;; Generate unified diff format string + (let ([hunks (diff-lines old new)] + [out (open-output-string)]) + (fprintf out "--- ~a~n" name1) + (fprintf out "+++ ~a~n" name2) + + ;; Group into context hunks + (let ([old-line 1] [new-line 1]) + (for-each + (lambda (entry) + (case (car entry) + [(keep) + (fprintf out " ~a~n" (cadr entry)) + (set! old-line (+ old-line 1)) + (set! new-line (+ new-line 1))] + [(remove) + (fprintf out "-~a~n" (cadr entry)) + (set! old-line (+ old-line 1))] + [(add) + (fprintf out "+~a~n" (cadr entry)) + (set! new-line (+ new-line 1))])) + hunks)) + (get-output-string out))) + + ;; ========== String Diff ========== + (define (diff-strings old-str new-str) + ;; Diff two strings line by line + (diff-lines (string-split-lines old-str) + (string-split-lines new-str))) + + ;; ========== Edit Distance (Levenshtein) ========== + (define (edit-distance s1 s2) + (let* ([m (string-length s1)] + [n (string-length s2)] + [dp (make-vector (* (+ m 1) (+ n 1)) 0)]) + ;; Initialize + (let loop ([i 0]) + (when (<= i m) (dp-set! dp m n i 0 i) (loop (+ i 1)))) + (let loop ([j 0]) + (when (<= j n) (dp-set! dp m n 0 j j) (loop (+ j 1)))) + ;; Fill + (let loop-i ([i 1]) + (when (<= i m) + (let loop-j ([j 1]) + (when (<= j n) + (let ([cost (if (char=? (string-ref s1 (- i 1)) + (string-ref s2 (- j 1))) 0 1)]) + (dp-set! dp m n i j + (min (+ (dp-ref dp m n (- i 1) j) 1) ;; delete + (+ (dp-ref dp m n i (- j 1)) 1) ;; insert + (+ (dp-ref dp m n (- i 1) (- j 1)) cost)))) ;; replace + (loop-j (+ j 1)))) + (loop-i (+ i 1)))) + (dp-ref dp m n m n))) + + ;; ========== Summary ========== + (define (diff-summary hunks) + ;; Returns (values additions deletions unchanged) + (let loop ([h hunks] [adds 0] [dels 0] [keeps 0]) + (if (null? h) + (values adds dels keeps) + (case (caar h) + [(add) (loop (cdr h) (+ adds 1) dels keeps)] + [(remove) (loop (cdr h) adds (+ dels 1) keeps)] + [(keep) (loop (cdr h) adds dels (+ keeps 1))])))) + + ;; ========== Apply ========== + (define (diff-apply old hunks) + ;; Apply diff hunks to produce new text + (let loop ([h hunks] [result '()]) + (if (null? h) + (reverse result) + (case (caar h) + [(keep) (loop (cdr h) (cons (cadar h) result))] + [(add) (loop (cdr h) (cons (cadar h) result))] + [(remove) (loop (cdr h) result)])))) + + ;; ========== Helpers ========== + (define (string-split-lines str) + (let ([n (string-length str)]) + (if (= n 0) '() + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i n) (reverse (cons (substring str start n) acc))] + [(char=? (string-ref str i) #\newline) + (loop (+ i 1) (+ i 1) (cons (substring str start i) acc))] + [else (loop (+ i 1) start acc)]))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/text/printf.sls @@ -0,0 +1,209 @@ +#!chezscheme +;;; (std text printf) -- C-style Format Strings +;;; +;;; Supports: %d %i %s %f %e %x %X %o %b %c %% +;;; With: width, precision, left-align (-), zero-pad (0), + sign +;;; +;;; Usage: +;;; (import (std text printf)) +;;; (sprintf "%d + %d = %d" 1 2 3) ; => "1 + 2 = 3" +;;; (sprintf "%08x" 255) ; => "000000ff" +;;; (sprintf "%.2f" 3.14159) ; => "3.14" +;;; (sprintf "%-20s|" "hello") ; => "hello |" +;;; (cprintf "%d items" 42) ; prints to current-output-port + +(library (std text printf) + (export + sprintf + cprintf + fprintf* + format-one) + + (import (chezscheme)) + + ;; ========== sprintf ========== + (define (sprintf fmt . args) + (let ([out (open-output-string)]) + (apply fprintf-impl out fmt args) + (get-output-string out))) + + ;; ========== cprintf (print to stdout) ========== + (define (cprintf fmt . args) + (apply fprintf-impl (current-output-port) fmt args)) + + ;; ========== fprintf* (print to port) ========== + (define (fprintf* port fmt . args) + (apply fprintf-impl port fmt args)) + + ;; ========== format-one ========== + (define (format-one fmt val) + ;; Format a single value with a format specifier + (sprintf fmt val)) + + ;; ========== Implementation ========== + (define (fprintf-impl port fmt . args) + (let ([n (string-length fmt)] + [args-left args]) + (let loop ([i 0]) + (when (< i n) + (let ([c (string-ref fmt i)]) + (cond + [(and (char=? c #\%) (< (+ i 1) n)) + (let-values ([(spec end) (parse-format-spec fmt (+ i 1))]) + (if (eq? (format-spec-type spec) 'percent) + (begin (display #\% port) + (loop end)) + (if (null? args-left) + (begin (display "<?>" port) + (loop end)) + (let ([val (car args-left)]) + (set! args-left (cdr args-left)) + (display (format-value spec val) port) + (loop end)))))] + [else + (display c port) + (loop (+ i 1))])))))) + + ;; ========== Format Spec ========== + (define-record-type format-spec + (fields (immutable flags) ;; string of flag chars + (immutable width) ;; #f or integer + (immutable precision) ;; #f or integer + (immutable type)) ;; symbol: 'd 'f 's 'x 'X 'o 'b 'e 'c 'percent + (protocol (lambda (new) + (lambda (flags width prec type) + (new flags width prec type))))) + + (define (parse-format-spec fmt start) + ;; Returns (values spec end-index) + (let ([n (string-length fmt)]) + ;; %% shortcut + (if (and (< start n) (char=? (string-ref fmt start) #\%)) + (values (make-format-spec "" #f #f 'percent) (+ start 1)) + ;; Parse flags + (let loop-flags ([i start] [flags '()]) + (if (and (< i n) (memv (string-ref fmt i) '(#\- #\+ #\0 #\space #\#))) + (loop-flags (+ i 1) (cons (string-ref fmt i) flags)) + ;; Parse width + (let-values ([(width i) (parse-number fmt i n)]) + ;; Parse precision + (let-values ([(prec i) + (if (and (< i n) (char=? (string-ref fmt i) #\.)) + (parse-number fmt (+ i 1) n) + (values #f i))]) + ;; Parse type + (if (< i n) + (let ([type (case (string-ref fmt i) + [(#\d #\i) 'd] + [(#\f) 'f] + [(#\e #\E) 'e] + [(#\s) 's] + [(#\x) 'x] + [(#\X) 'X] + [(#\o) 'o] + [(#\b) 'b] + [(#\c) 'c] + [else 's])]) + (values (make-format-spec (list->string (reverse flags)) + width prec type) + (+ i 1))) + (values (make-format-spec "" #f #f 's) i))))))))) + + (define (parse-number fmt i n) + (let loop ([i i] [num #f]) + (if (and (< i n) (char-numeric? (string-ref fmt i))) + (loop (+ i 1) (+ (* (or num 0) 10) (- (char->integer (string-ref fmt i)) 48))) + (values num i)))) + + ;; ========== Value Formatting ========== + (define (format-value spec val) + (let* ([type (format-spec-type spec)] + [raw (case type + [(d) (if (number? val) (number->string (exact (truncate val))) (format "~a" val))] + [(f) (format-float val (or (format-spec-precision spec) 6))] + [(e) (format-scientific val (or (format-spec-precision spec) 6))] + [(s) (if (string? val) val (format "~a" val))] + [(x) (if (number? val) + (string-downcase (number->string (exact (truncate val)) 16)) + (format "~a" val))] + [(X) (if (number? val) + (string-upcase (number->string (exact (truncate val)) 16)) + (format "~a" val))] + [(o) (if (number? val) + (number->string (exact (truncate val)) 8) + (format "~a" val))] + [(b) (if (number? val) + (number->string (exact (truncate val)) 2) + (format "~a" val))] + [(c) (if (char? val) (string val) + (if (integer? val) (string (integer->char val)) + (format "~a" val)))] + [else (format "~a" val)])] + [flags (format-spec-flags spec)] + [width (format-spec-width spec)] + [left-align (string-contains-char? flags #\-)] + [zero-pad (string-contains-char? flags #\0)] + [plus (string-contains-char? flags #\+)]) + + ;; Add + sign for positive numbers if requested + (let ([raw (if (and plus (memq type '(d f e)) + (number? val) (>= val 0)) + (string-append "+" raw) + raw)]) + ;; Apply width padding + (if (and width (> width (string-length raw))) + (let ([pad-char (if (and zero-pad (not left-align) + (memq type '(d f e x X o b))) #\0 #\space)] + [pad-len (- width (string-length raw))]) + (if left-align + (string-append raw (make-string pad-len #\space)) + (string-append (make-string pad-len pad-char) raw))) + raw)))) + + (define (format-float val prec) + (if (not (number? val)) (format "~a" val) + (let* ([v (inexact val)] + [neg (< v 0)] + [v (abs v)] + [factor (expt 10 prec)] + [rounded (/ (round (* v factor)) factor)] + [int-part (exact (floor rounded))] + [frac-part (- rounded int-part)] + [frac-str (let ([s (number->string (exact (round (* frac-part factor))))]) + (let pad ([s s]) + (if (< (string-length s) prec) + (pad (string-append "0" s)) + s)))]) + (string-append (if neg "-" "") + (number->string int-part) + "." + frac-str)))) + + (define (format-scientific val prec) + (if (not (number? val)) (format "~a" val) + (let* ([v (inexact val)] + [neg (< v 0)] + [v (abs v)] + [exp (if (= v 0.0) 0 (exact (floor (log10 v))))] + [mantissa (if (= v 0.0) 0.0 (/ v (expt 10.0 exp)))]) + (string-append (if neg "-" "") + (format-float mantissa prec) + "e" + (if (>= exp 0) "+" "-") + (let ([s (number->string (abs exp))]) + (if (< (string-length s) 2) + (string-append "0" s) + s)))))) + + (define (log10 x) + (/ (log x) (log 10))) + + (define (string-contains-char? s c) + (let ([n (string-length s)]) + (let loop ([i 0]) + (cond + [(= i n) #f] + [(char=? (string-ref s i) c) #t] + [else (loop (+ i 1))])))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-batch5.ss @@ -0,0 +1,372 @@ +#!chezscheme +;;; Tests for batch 5: diff, ringbuf, printf, heap, lru-cache + +(import (chezscheme) + (std text diff) + (std misc ringbuf) + (std text printf) + (std misc heap) + (std misc lru-cache)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] + [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected ~s)~n" 'expr result exp))))])) + +(define-syntax check-true + (syntax-rules () + [(_ expr) + (let ([result expr]) + (if result + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected truthy)~n" 'expr result))))])) + +(define-syntax check-false + (syntax-rules () + [(_ expr) + (let ([result expr]) + (if (not result) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected falsy)~n" 'expr result))))])) + +(define (string-contains* haystack needle) + (let ([hn (string-length haystack)] + [nn (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nn) hn) #f] + [(string=? (substring haystack i (+ i nn)) needle) #t] + [else (loop (+ i 1))])))) + +(printf "--- Testing batch 5 modules ---~n") + +;; ========== (std text diff) ========== +(printf " Diff...~n") + +;; diff-lines: no changes +(check (diff-lines '("a" "b" "c") '("a" "b" "c")) + => '((keep "a") (keep "b") (keep "c"))) + +;; diff-lines: additions +(let ([d (diff-lines '("a" "c") '("a" "b" "c"))]) + (check-true (member '(add "b") d))) + +;; diff-lines: removals +(let ([d (diff-lines '("a" "b" "c") '("a" "c"))]) + (check-true (member '(remove "b") d))) + +;; diff-lines: replacement +(let ([d (diff-lines '("a" "b" "c") '("a" "x" "c"))]) + (check-true (member '(remove "b") d)) + (check-true (member '(add "x") d))) + +;; diff-lines: empty +(check (diff-lines '() '()) => '()) +(let ([d (diff-lines '() '("a"))]) + (check-true (member '(add "a") d))) + +;; diff-unified +(let ([u (diff-unified "old" "new" '("a" "b") '("a" "c"))]) + (check-true (string-contains* u "--- old")) + (check-true (string-contains* u "+++ new")) + (check-true (string-contains* u "-b")) + (check-true (string-contains* u "+c"))) + +;; diff-strings +(let ([d (diff-strings "a\nb\nc" "a\nx\nc")]) + (check-true (member '(remove "b") d)) + (check-true (member '(add "x") d))) + +;; edit-distance +(check (edit-distance "kitten" "sitting") => 3) +(check (edit-distance "" "") => 0) +(check (edit-distance "abc" "abc") => 0) +(check (edit-distance "abc" "") => 3) +(check (edit-distance "" "abc") => 3) + +;; diff-summary +(let-values ([(adds dels keeps) (diff-summary '((keep "a") (remove "b") (add "x") (keep "c")))]) + (check adds => 1) + (check dels => 1) + (check keeps => 2)) + +;; diff-apply +(check (diff-apply '("a" "b" "c") '((keep "a") (remove "b") (add "x") (keep "c"))) + => '("a" "x" "c")) + +;; ========== (std misc ringbuf) ========== +(printf " Ring buffer...~n") + +;; Basic +(let ([rb (make-ringbuf 5)]) + (check-true (ringbuf? rb)) + (check (ringbuf-capacity rb) => 5) + (check-true (ringbuf-empty? rb)) + (check (ringbuf-size rb) => 0) + + (ringbuf-push! rb 1) + (ringbuf-push! rb 2) + (ringbuf-push! rb 3) + (check (ringbuf-size rb) => 3) + (check-false (ringbuf-full? rb)) + (check (ringbuf-peek rb) => 1) + (check (ringbuf-peek-newest rb) => 3) + + (check (ringbuf-pop! rb) => 1) + (check (ringbuf-pop! rb) => 2) + (check (ringbuf-size rb) => 1)) + +;; ringbuf->list +(let ([rb (make-ringbuf 5)]) + (ringbuf-push! rb 'a) + (ringbuf-push! rb 'b) + (ringbuf-push! rb 'c) + (check (ringbuf->list rb) => '(a b c))) + +;; Overwrite when full +(let ([rb (make-ringbuf 3)]) + (ringbuf-push! rb 1) + (ringbuf-push! rb 2) + (ringbuf-push! rb 3)