Changeset 27174 in project for release/4/tuples/trunk/tuples.scm
 Timestamp:
 08/03/12 12:11:06 (9 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

release/4/tuples/trunk/tuples.scm
r26086 r27174 33 33 ; ju (at) jugilo (dot) de 34 34 ; 35 ; Last update: Mar 07, 201235 ; Last update: Aug 02, 2012 36 36 ; 37 37 ;In this module, we'll implement tuples, a container structure like … … 51 51 ;and coupleright. 52 52 53 (require 'contracts) 54 55 (module tuples ;* 53 (requirelibrary contracts) 54 55 (module %tuples 56 (tuple tuple? tuplelength tupleref tuplefind 57 tuplemap tupleappend list>tuple tuple>list tupleforeach 58 empty empty? single single? singleref singleset! tupleof? 59 couple couple? coupleleft coupleright triple triple? tripleleft 60 triplemiddle tripleright tupleleft tupleright tuplecopy) 61 62 (import scheme 63 (only chicken unless conditioncase caselambda defineinline 64 openoutputstring getoutputstring) 65 (only datastructures listof?)) 66 67 ;;; implementation and helpers 68 ;;; must appear before interface, because some routines are inlined 69 70 (defineinline (project n) 71 (lambda args 72 (listref args n))) 73 74 (define (tuplelength tup) 75 (tup (project 1))) 76 77 (define (tupleref tup n) 78 (tup (project (+ n 2)))) 79 80 (define (tupleleft tup) 81 (tup (project 2))) 82 83 (define (tupleright tup) 84 (tup (project (+ (tuplelength tup) 1)))) 85 86 (define (tuple? xpr) 87 (and (procedure? xpr) 88 (conditioncase (eq? 'tuple (xpr (project 0))) 89 ((exn) #f)))) 90 91 (define (tupleof? ok?) 92 (lambda (x) 93 (and (tuple? x) 94 (let helper ((n (tuplelength x))) 95 (if (zero? n) 96 #t 97 (and (ok? (tupleref x ( n 1))) (helper ( n 1)))))))) 98 99 (define (tuple . args) 100 (lambda (sel) 101 (apply sel (cons 'tuple (cons (length args) args))))) 102 103 (define (tuplemap fn tup) 104 (let loop ((n (tuplelength tup)) (acc '())) 105 (if (zero? n) 106 (apply tuple acc) 107 (loop ( n 1) (cons (fn (tupleref tup ( n 1))) acc))))) 108 109 (define (tupleappend . tups) 110 (lambda (sel) 111 (apply sel (cons 'tuple 112 (cons (apply + (map tuplelength tups)) 113 (apply append (map tuple>list tups))))))) 114 115 (define (tuple>list tup) 116 (let loop ((n (tuplelength tup)) (acc '())) 117 (if (zero? n) 118 acc 119 (loop ( n 1) (cons (tupleref tup ( n 1)) acc))))) 120 121 (define (tuplecopy tup . intervall) 122 (let ( 123 (from (if (null? intervall) 124 0 125 (car intervall))) 126 (upto (if (< (length intervall) 2) 127 (tuplelength tup) 128 (cadr intervall))) 129 ) 130 (let loop ((n upto) (acc '())) 131 (if (= from n) 132 (apply tuple acc) 133 (loop ( n 1) (cons (tupleref tup ( n 1)) acc)))))) 134 135 (define (tuplefind tup item compare?) 136 (let ((len (tuplelength tup))) 137 (if (zero? len) 138 #f 139 (let loop ((result 0)) 140 (cond 141 ((= result len) #f) 142 ((compare? item (tupleref tup result)) result) 143 (else (loop (+ result 1)))))))) 144 145 (define (tupleforeach proc tup) 146 (let ((len (tuplelength tup))) 147 (let loop ((n 0)) 148 (unless (= n len) 149 (proc (tupleref tup n)) 150 (loop (+ n 1)))))) 151 152 (define (list>tuple lst) 153 (apply tuple lst)) 154 155 ;;; empties are 0tuples 156 (define (empty) 157 (tuple)) 158 159 (define (empty? x) 160 (and (tuple? x) (= (tuplelength x) 0))) 161 162 ;;; singles as mutable 1tuples 163 (define (single? xpr) 164 (and (procedure? xpr) 165 (conditioncase (eq? 'single (xpr (project 0))) 166 ((exn) #f)))) 167 168 (define (single xpr) 169 (lambda (sel) 170 (sel 'single xpr (lambda (new) (set! xpr new))))) 171 172 ;;; query 173 (define (singleref sg) 174 (sg (project 1))) 175 176 ;;; command 177 (define (singleset! sg arg) 178 ((sg (project 2)) arg)) 179 180 ;;; couples are tuples which store two items 181 (define (couple? x) 182 (and (tuple? x) (= (tuplelength x) 2))) 183 184 (define (couple x y) 185 (tuple 1 2)) 186 187 (define (coupleleft tup) 188 (tupleref tup 0)) 189 190 (define (coupleright tup) 191 (tupleref tup 1)) 192 193 ;;; triples are tuples which store three items 194 (define (triple? x) 195 (and (tuple? x) (= (tuplelength x) 3))) 196 197 (define (triple x y z) 198 (tuple x y z)) 199 200 (define (tripleleft tup) 201 (tupleref tup 0)) 202 203 (define (triplemiddle tup) 204 (tupleref tup 1)) 205 206 (define (tripleright tup) 207 (tupleref tup 2)) 208 209 ) ; module %tuples 210 211 (module tuples 56 212 (tuples tuple tuple? tupleof? tuplelength tupleref tuplefind 57 213 tuplemap tupleappend list>tuple tuple>list tupleforeach … … 62 218 (import scheme 63 219 contracts 220 (prefix %tuples %) 64 221 (only chicken unless conditioncase caselambda defineinline 65 222 openoutputstring getoutputstring) … … 73 230 74 231 (defineinline (true? x) #t) 75 76 (defineinline (project n)77 (lambda args78 (listref args n)))79 80 (defineinline (%tuplelength tup)81 (tup (project 1)))82 83 (defineinline (%tupleref tup n)84 (tup (project (+ n 2))))85 86 (defineinline (%tupleleft tup)87 (tup (project 2)))88 89 (defineinline (%tupleright tup)90 (tup (project (+ (%tuplelength tup) 1))))91 92 (defineinline (%tuplestate sg)93 (sg (project 1)))94 95 (defineinline (%tuplestate! sg arg)96 ((sg (project 2)) arg))97 98 (define (%tuple? xpr)99 (and (procedure? xpr)100 (conditioncase (eq? 'tuple (xpr (project 0)))101 ((exn) #f))))102 103 (define (%tupleof? ok?)104 (lambda (x)105 (and (%tuple? x)106 (let helper ((n (%tuplelength x)))107 (if (zero? n)108 #t109 (and (ok? (%tupleref x ( n 1))) (helper ( n 1))))))))110 111 (define (%tuple . args)112 (lambda (sel)113 (apply sel (cons 'tuple (cons (length args) args)))))114 115 (define (%tuplemap fn tup)116 (let loop ((n (%tuplelength tup)) (acc '()))117 (if (zero? n)118 (apply %tuple acc)119 (loop ( n 1) (cons (fn (%tupleref tup ( n 1))) acc)))))120 121 (define (%tupleappend . tups)122 (lambda (sel)123 (apply sel (cons 'tuple124 (cons (apply + (map %tuplelength tups))125 (apply append (map %tuple>list tups)))))))126 127 (define (%tuple>list tup)128 (let loop ((n (%tuplelength tup)) (acc '()))129 (if (zero? n)130 acc131 (loop ( n 1) (cons (%tupleref tup ( n 1)) acc)))))132 133 (define (%tuplecopy tup . intervall)134 (let (135 (from (if (null? intervall)136 0137 (car intervall)))138 (upto (if (< (length intervall) 2)139 (%tuplelength tup)140 (cadr intervall)))141 )142 (let loop ((n upto) (acc '()))143 (if (= from n)144 (apply %tuple acc)145 (loop ( n 1) (cons (%tupleref tup ( n 1)) acc))))))146 147 (define (%tuplefind tup item compare?)148 (let ((len (%tuplelength tup)))149 (if (zero? len)150 #f151 (let loop ((result 0))152 (cond153 ((= result len) #f)154 ((compare? item (%tupleref tup result)) result)155 (else (loop (+ result 1))))))))156 157 (define (%tupleforeach proc tup)158 (let ((len (%tuplelength tup)))159 (let loop ((n 0))160 (unless (= n len)161 (proc (%tupleref tup n))162 (loop (+ n 1))))))163 164 (define (%single? xpr)165 (and (procedure? xpr)166 (conditioncase (eq? 'single (xpr (project 0)))167 ((exn) #f))))168 169 (define (%single xpr)170 (lambda (sel)171 (sel 'single xpr (lambda (new) (set! xpr new)))))172 173 ;; initialize documentation174 (doclist '())175 176 ;;; iterface177 178 ;;; general ntuples179 232 180 233 ;;; predicates … … 297 350 "returns the state of the single object sg" 298 351 (domain (%single? sg)) 299 (% tuplestatesg))352 (%singleref sg)) 300 353 301 354 ;;; command … … 303 356 "replaces state of sg with arg" 304 357 (domain (%single? sg) (true? arg)) 305 (effect (state (% tuplestatesg) arg))306 (% tuplestate! sg arg))358 (effect (state (%singleref sg) arg)) 359 (%singleset! sg arg)) 307 360 308 361 ;;; couples are tuples which store two items
Note: See TracChangeset
for help on using the changeset viewer.