Changeset 37361 in project
 Timestamp:
 03/12/19 20:42:26 (4 months ago)
 Location:
 release/5/cis/trunk
 Files:

 2 edited
Legend:
 Unmodified
 Added
 Removed

release/5/cis/trunk/cis.scm
r36461 r37361 100 100 (define (cis? x) (and (pair? x) (eq? 'cis (car x)))) 101 101 102 103 104 105 106 102 (define (empty? x) 103 (cases cis x 104 ((Nil) #t) 105 ((Single _ _) #f) 106 ((Interv _ _ _) #f))) 107 107 108 108 109 (define empty (Nil)) 110 111 (define (subset? t1 t2) 112 (cases cis t1 113 ((Nil) #t) 114 ((Single x1 t1tail) 115 (cases cis t2 116 ((Nil) #f) 117 ((Single x2 t2tail) 118 (cond ((> x1 x2) #f) 119 ((> x2 x1) (subset? t1 t2tail)) 120 (else (subset? t1tail t2tail)))) 121 ((Interv xmax2 xmin2 t2tail) 122 (cond ((> x1 xmax2) #f) 123 ((> xmin2 x1) (subset? t1 t2tail)) 124 (else (subset? t1tail t2)))))) 125 ((Interv xmax1 xmin1 t1tail) 126 (cases cis t2 127 ((Nil) #f) 128 ((Single x2 t2tail) 129 (cond ((> x2 xmax1) (subset? t1 t2tail)) 130 ((> xmin1 x2) #f) 131 (else #f))) 132 ((Interv xmax2 xmin2 t2tail) 133 (cond ((> xmin2 xmax1) (subset? t1 t2tail)) 134 ((> xmin1 xmax2) #f) 135 (else (and (>= xmax2 xmax1) (>= xmin1 xmin2) (subset? t1tail t2))))) 136 )) 137 )) 138 139 140 (define (getmax t) 109 (define empty (Nil)) 110 111 (define (subset? t1 t2) 112 (cases cis t1 113 ((Nil) #t) 114 ((Single x1 t1tail) 115 (cases cis t2 116 ((Nil) #f) 117 ((Single x2 t2tail) 118 (cond ((> x1 x2) #f) 119 ((> x2 x1) (subset? t1 t2tail)) 120 (else (subset? t1tail t2tail)))) 121 ((Interv xmax2 xmin2 t2tail) 122 (cond ((> x1 xmax2) #f) 123 ((> xmin2 x1) (subset? t1 t2tail)) 124 (else (subset? t1tail t2)))))) 125 ((Interv xmax1 xmin1 t1tail) 126 (cases cis t2 127 ((Nil) #f) 128 ((Single x2 t2tail) 129 (cond ((> x2 xmax1) (subset? t1 t2tail)) 130 ((> xmin1 x2) #f) 131 (else #f))) 132 ((Interv xmax2 xmin2 t2tail) 133 (cond ((> xmin2 xmax1) (subset? t1 t2tail)) 134 ((> xmin1 xmax2) #f) 135 (else (and (>= xmax2 xmax1) (>= xmin1 xmin2) (subset? t1tail t2))))) 136 )) 137 )) 138 139 140 (define (getmax t) 141 (cases cis t 142 ((Nil) (error 'getmax "set is empty")) 143 ((Single x _) x) 144 ((Interv xmax _ _) xmax))) 145 146 147 (define (getmin t) 148 (cases cis t 149 ((Nil) (error 'getmin "set is empty")) 150 ((Single x t1) (if (empty? t1) x (getmin t1))) 151 ((Interv xmax xmin t1) (if (empty? t1) xmin (getmin t1))))) 152 153 154 (define (conssingle x t) 155 (cases cis t 156 ((Nil) 157 (Single x (Nil))) 158 ((Single x1 t1) 159 (if (= x (+ 1 x1)) (Interv x x1 t1) (Single x t))) 160 ((Interv xmax1 xmin1 t1) 161 (if (= x (+ 1 xmax1)) (Interv x xmin1 t1) (Single x t))) 162 )) 163 164 165 (define (consinterval xmax xmin t) 166 (cond ((< xmax xmin) t) 167 ((= xmax xmin) (conssingle xmin t)) 168 (else 169 (cases cis t 170 ((Nil) 171 (Interv xmax xmin (Nil))) 172 ((Single x1 t1) 173 (if (= xmin (+ 1 x1)) (Interv xmax x1 t1) (Interv xmax xmin t))) 174 ((Interv xmax1 xmin1 t1) 175 (if (= xmin (+ 1 xmax1)) (Interv xmax xmin1 t1) (Interv xmax xmin t))) 176 )) 177 )) 178 179 180 (define (cardinal t) 181 (let recur ((t t) (ax 0)) 141 182 (cases cis t 142 ((Nil) (error 'getmax "set is empty")) 143 ((Single x _) x) 144 ((Interv xmax _ _) xmax))) 145 146 147 (define (getmin t) 148 (cases cis t 149 ((Nil) (error 'getmin "set is empty")) 150 ((Single x t1) (if (empty? t1) x (getmin t1))) 151 ((Interv xmax xmin t1) (if (empty? t1) xmin (getmin t1))))) 152 153 154 (define (conssingle x t) 155 (cases cis t 156 ((Nil) 157 (Single x (Nil))) 158 ((Single x1 t1) 159 (if (= x (+ 1 x1)) (Interv x x1 t1) (Single x t))) 160 ((Interv xmax1 xmin1 t1) 161 (if (= x (+ 1 xmax1)) (Interv x xmin1 t1) (Single x t))) 162 )) 163 164 165 (define (consinterval xmax xmin t) 166 (cond ((< xmax xmin) (consinterval xmin xmax t)) 167 ((= xmax xmin) (conssingle xmin t)) 168 (else 169 (cases cis t 170 ((Nil) 171 (Interv xmax xmin (Nil))) 172 ((Single x1 t1) 173 (if (= xmin (+ 1 x1)) (Interv xmax x1 t1) (Interv xmax xmin t))) 174 ((Interv xmax1 xmin1 t1) 175 (if (= xmin (+ 1 xmax1)) (Interv xmax xmin1 t1) (Interv xmax xmin t))) 176 )) 177 )) 178 179 180 (define (cardinal t) 181 (let recur ((t t) (ax 0)) 182 (cases cis t 183 ((Nil) ax) 184 ((Single x1 t1) (recur t1 (+ 1 ax))) 185 ((Interv xmax1 xmin1 t1) (recur t1 (+ ax (+ 1 ( xmax1 xmin1))))) 186 ))) 187 188 189 (define (in? x t) 190 (cases cis t 191 ((Nil) #f) 192 ((Single x1 t1) 193 (or (= x x1) (and (> x1 x) (in? x t1)))) 194 ((Interv xmax xmin t1) 195 (or (and (>= xmax x) (>= x xmin)) 196 (and (> xmin x) (in? x t1)))) 197 )) 183 ((Nil) ax) 184 ((Single x1 t1) (recur t1 (+ 1 ax))) 185 ((Interv xmax1 xmin1 t1) (recur t1 (+ ax (+ 1 ( xmax1 xmin1))))) 186 ))) 187 188 189 (define (in? x t) 190 (cases cis t 191 ((Nil) #f) 192 ((Single x1 t1) 193 (or (= x x1) (and (> x1 x) (in? x t1)))) 194 ((Interv xmax xmin t1) 195 (or (and (>= xmax x) (>= x xmin)) 196 (and (> xmin x) (in? x t1)))) 197 )) 198 198 199 199 … … 218 218 ((and (>= xmax1 x) (>= x xmin1)) t) 219 219 (else (consinterval xmax1 xmin1 (add x t1))))) 220 220 221 221 )) 222 222 … … 253 253 (Interv (+ xmax1 n) (+ xmin1 n) (shift n t1))) 254 254 ))))) 255 256 255 256 257 257 258 258 (define (union t1 t2) … … 261 261 ((Single x1 t1tail) 262 262 (begin 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 263 (cases cis t2 264 ((Nil) t1) 265 ((Single x2 t2tail) 266 (cond ((> x1 (+ 1 x2)) 267 (conssingle x1 (union t1tail t2))) 268 ((> x2 (+ 1 x1)) 269 (conssingle x2 (union t1 t2tail))) 270 ((= x1 (+ 1 x2)) 271 (consinterval x1 x2 (union t1tail t2tail))) 272 ((= x2 (+ 1 x1)) 273 (consinterval x2 x1 (union t1tail t2tail))) 274 (else 275 (conssingle x1 (union t1tail t2tail))) 276 )) 277 ((Interv xmax2 xmin2 t2tail) 278 278 (cond ((> x1 xmax2) (conssingle x1 (union t1tail t2))) 279 279 ((> xmin2 (+ 1 x1)) (consinterval xmax2 xmin2 (union t1 t2tail))) 280 280 ((= xmin2 (+ 1 x1)) (consinterval xmax2 x1 (union t1tail t2tail))) 281 281 (else (consinterval xmax2 x1 (union t1tail (consinterval ( x1 1) xmin2 t2tail)))))) 282 282 ))) 283 283 284 284 ((Interv xmax1 xmin1 t1tail) … … 308 308 (cases cis t1 309 309 ((Nil) empty) 310 ((Single x1 t1tail) 311 (cases cis t2 312 ((Nil) empty) 313 ((Single x2 t2tail) 314 (cond ((> x1 (+ 1 x2)) 315 (intersection t1tail t2)) 316 ((> x2 (+ 1 x1)) 317 (intersection t1 t2tail)) 318 ((= x1 (+ 1 x2)) 319 (intersection t1tail t2tail)) 320 ((= x2 (+ 1 x1)) 321 (intersection t1tail t2tail)) 322 (else 323 (conssingle x1 (intersection t1tail t2tail))) 324 )) 325 ((Interv xmax2 xmin2 t2tail) 326 (cond ((> x1 xmax2) (intersection t1tail t2)) 327 ((> xmin2 x1) (intersection t1 t2tail)) 328 (else (conssingle x1 (intersection t1tail t2))))) 329 )) 330 ((Interv xmax1 xmin1 t1tail) 331 (cases cis t2 332 ((Nil) empty) 333 ((Single x2 t2tail) 334 (cond ((> x2 xmax1) (intersection t1 t2tail)) 335 ((> xmin1 x2) (intersection t1tail t2)) 336 (else (conssingle x2 (intersection t1 t2tail))))) 337 ((Interv xmax2 xmin2 t2tail) 338 (cond ((> xmin2 xmax1) (intersection t1 t2tail)) 339 ((> xmin1 xmax2) (intersection t1tail t2)) 340 (else (consinterval (min xmax1 xmax2) (max xmin1 xmin2) 341 (if (>= xmin1 xmin2) 342 (intersection t1tail t2) 343 (intersection t1 t2tail)))))) 344 )) 345 )) 346 347 (define (difference t1 t2) 348 (cases cis t1 349 ((Nil) empty) 350 ((Single x1 t1tail) 351 (cases cis t2 352 ((Nil) t1) 353 ((Single x2 t2tail) 354 (cond ((> x1 x2) (conssingle x1 (difference t1tail t2))) 355 ((> x2 x1) (difference t1 t2tail)) 356 (else (difference t1tail t2tail)))) 357 ((Interv xmax2 xmin2 t2tail) 358 (cond ((> x1 xmax2) (conssingle x1 (difference t1tail t2))) 359 ((> xmin2 x1) (difference t1 t2tail)) 360 (else (difference t1tail t2tail)))))) 361 ((Interv xmax1 xmin1 t1tail) 362 (cases cis t2 363 ((Nil) t1) 364 ((Single x2 t2tail) 365 (cond ((> x2 xmax1) (difference t1 t2tail)) 366 ((> xmin1 x2) (consinterval xmax1 xmin1 (difference t1tail t2))) 367 (else (consinterval xmax1 (+ 1 x2) (difference (consinterval ( x2 1) xmin1 t1tail) 368 t2tail))))) 369 ((Interv xmax2 xmin2 t2tail) 370 (cond ((> xmin2 xmax1) (difference t1 t2tail)) 371 ((> xmin1 xmax2) (consinterval xmax1 xmin1 (difference t1tail t2))) 372 (else 373 (consinterval xmax1 (+ 1 xmax2) 374 (if (>= xmin1 xmin2) 375 (difference t1tail t2) 376 (difference (consinterval ( xmin2 1) xmin1 t1tail) 377 t2tail)))))) 378 )) 379 )) 380 381 382 310 ((Single x1 t1tail) 311 (cases cis t2 312 ((Nil) empty) 313 ((Single x2 t2tail) 314 (cond ((> x1 (+ 1 x2)) 315 (intersection t1tail t2)) 316 ((> x2 (+ 1 x1)) 317 (intersection t1 t2tail)) 318 ((= x1 (+ 1 x2)) 319 (intersection t1tail t2tail)) 320 ((= x2 (+ 1 x1)) 321 (intersection t1tail t2tail)) 322 (else 323 (conssingle x1 (intersection t1tail t2tail))) 324 )) 325 ((Interv xmax2 xmin2 t2tail) 326 (cond ((> x1 xmax2) (intersection t1tail t2)) 327 ((> xmin2 x1) (intersection t1 t2tail)) 328 (else (conssingle x1 (intersection t1tail t2))))) 329 )) 330 ((Interv xmax1 xmin1 t1tail) 331 (cases cis t2 332 ((Nil) empty) 333 ((Single x2 t2tail) 334 (cond ((> x2 xmax1) (intersection t1 t2tail)) 335 ((> xmin1 x2) (intersection t1tail t2)) 336 (else (conssingle x2 (intersection t1 t2tail))))) 337 ((Interv xmax2 xmin2 t2tail) 338 (cond ((> xmin2 xmax1) (intersection t1 t2tail)) 339 ((> xmin1 xmax2) (intersection t1tail t2)) 340 (else (consinterval (min xmax1 xmax2) (max xmin1 xmin2) 341 (if (>= xmin1 xmin2) 342 (intersection t1tail t2) 343 (intersection t1 t2tail)))))) 344 )) 345 )) 346 347 (define (difference t1 t2) 348 (cases cis t1 349 ((Nil) empty) 350 ((Single x1 t1tail) 351 (cases cis t2 352 ((Nil) t1) 353 ((Single x2 t2tail) 354 (cond ((> x1 x2) (conssingle x1 (difference t1tail t2))) 355 ((> x2 x1) (difference t1 t2tail)) 356 (else (difference t1tail t2tail)))) 357 ((Interv xmax2 xmin2 t2tail) 358 (cond ((> x1 xmax2) (conssingle x1 (difference t1tail t2))) 359 ((> xmin2 x1) (difference t1 t2tail)) 360 (else (difference t1tail t2tail)))))) 361 ((Interv xmax1 xmin1 t1tail) 362 (cases cis t2 363 ((Nil) t1) 364 ((Single x2 t2tail) 365 (cond ((> x2 xmax1) (difference t1 t2tail)) 366 ((> xmin1 x2) (consinterval xmax1 xmin1 (difference t1tail t2))) 367 ;; x2 <= xmax1 & xmin1 <= x2 368 (else (consinterval xmax1 (+ 1 x2) (difference (consinterval ( x2 1) xmin1 t1tail) 369 t2tail))))) 370 ((Interv xmax2 xmin2 t2tail) 371 (cond ((> xmin2 xmax1) (difference t1 t2tail)) 372 ((> xmin1 xmax2) (consinterval xmax1 xmin1 (difference t1tail t2))) 373 (else 374 (consinterval xmax1 (+ 1 xmax2) 375 (if (> xmin1 xmin2) 376 (difference t1tail t2) 377 (difference (consinterval ( xmin2 1) xmin1 t1tail) 378 (if (> xmax1 xmax2) t2tail (interval xmax2 (+ 1 xmax1)))))))) 379 )) 380 )) 381 ) 382 383 383 384 (define (foreach f t) 384 385 (let outer ((t t)) 
release/5/cis/trunk/tests/run.scm
r36461 r37361 23 23 ) 24 24 25 (testgroup "set operations "25 (testgroup "set operations 1" 26 26 (let ((t (add 4 (add 1 (add 5 empty))))) 27 27 (test "adding elements out of order" '(5 4 1) (elements t))) … … 60 60 )) 61 61 62 (testgroup "difference operations" 63 64 (test "difference of an interval and a singleton" 65 '(1) (elements (difference (interval 1 2) (singleton 2)))) 66 (test "difference of nonoverlapping ranges" 67 '(2) (elements (difference (interval 2 4) (interval 3 5)))) 68 (test "difference of nonoverlapping ranges" 69 '(5) (elements (difference (interval 3 5) (interval 2 4)))) 70 ) 62 71 63 72 (testexit)
Note: See TracChangeset
for help on using the changeset viewer.