Artifact 1d66604c3291da8aa6a7e9be70c2eb18146e5da0:
- File items.scm — part of check-in [ae6dbecf17] at 2011-05-01 23:05:22 on branch trunk — Importing 1.0.1 version of megatest, (nb// work in progress, please wait for next release) (user: matt size: 2086)
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20 0010: 30 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 06-2011, Matthew 0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;; 0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i 0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available 0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G 0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o 0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S 0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany 0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING 00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;; 00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr 00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute 00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA 00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without 00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp 0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of 0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY 0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR 0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;; 0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 0a 3b 3b 20 28 PURPOSE....;; ( 0150: 64 65 66 69 6e 65 20 69 74 65 6d 64 61 74 20 27 define itemdat ' 0160: 28 28 72 69 70 65 6e 65 73 73 20 20 20 20 22 67 ((ripeness "g 0170: 72 65 65 6e 20 72 69 70 65 20 6f 76 65 72 72 69 reen ripe overri 0180: 70 65 22 29 0a 3b 3b 20 09 09 20 20 28 74 65 6d pe").;; .. (tem 0190: 70 65 72 61 74 75 72 65 20 22 63 6f 6f 6c 20 6d perature "cool m 01a0: 65 64 69 75 6d 20 68 6f 74 22 29 0a 3b 3b 20 09 edium hot").;; . 01b0: 09 20 20 28 73 65 61 73 6f 6e 20 20 20 20 20 20 . (season 01c0: 22 73 75 6d 6d 65 72 20 77 69 6e 74 65 72 20 66 "summer winter f 01d0: 61 6c 6c 20 73 70 72 69 6e 67 22 29 29 29 0a 0a all spring"))).. 01e0: 3b 3b 20 4d 6f 73 74 6c 79 20 77 6f 72 6b 65 64 ;; Mostly worked 01f0: 20 3d 20 70 75 74 73 20 6f 75 74 20 61 6c 6c 20 = puts out all 0200: 63 6f 6d 62 69 6e 61 74 69 6f 6e 73 3f 0a 28 64 combinations?.(d 0210: 65 66 69 6e 65 20 28 70 72 6f 63 65 73 73 2d 69 efine (process-i 0220: 74 65 6d 6c 69 73 74 2d 74 72 79 31 20 63 75 72 temlist-try1 cur 0230: 72 69 74 65 6d 6b 65 79 20 69 74 65 6d 6c 69 73 ritemkey itemlis 0240: 74 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 t). (let loop ( 0250: 28 68 65 64 20 28 63 61 72 20 69 74 65 6d 6c 69 (hed (car itemli 0260: 73 74 29 29 0a 09 20 20 20 20 20 28 74 61 6c 20 st)).. (tal 0270: 28 63 64 72 20 69 74 65 6d 6c 69 73 74 29 29 29 (cdr itemlist))) 0280: 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null? 0290: 74 61 6c 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 tal)..(for-each 02a0: 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 0a 09 (lambda (item).. 02b0: 09 20 20 20 20 28 70 72 69 6e 74 20 22 63 75 72 . (print "cur 02c0: 72 69 74 65 6d 6b 65 79 3a 20 22 20 28 61 70 70 ritemkey: " (app 02d0: 65 6e 64 20 63 75 72 72 69 74 65 6d 6b 65 79 20 end curritemkey 02e0: 28 6c 69 73 74 20 69 74 65 6d 29 29 29 29 0a 09 (list item)))).. 02f0: 09 20 20 28 63 61 64 72 20 68 65 64 29 29 0a 09 . (cadr hed)).. 0300: 28 62 65 67 69 6e 0a 09 20 20 28 66 6f 72 2d 65 (begin.. (for-e 0310: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 69 74 65 ach (lambda (ite 0320: 6d 29 0a 09 09 20 20 20 20 20 20 28 70 72 6f 63 m)... (proc 0330: 65 73 73 2d 69 74 65 6d 6c 69 73 74 20 28 61 70 ess-itemlist (ap 0340: 70 65 6e 64 20 63 75 72 72 69 74 65 6d 6b 65 79 pend curritemkey 0350: 20 28 6c 69 73 74 20 69 74 65 6d 29 29 20 74 61 (list item)) ta 0360: 6c 29 29 0a 09 09 20 20 20 20 28 63 61 64 72 20 l))... (cadr 0370: 68 65 64 29 29 0a 09 20 20 28 6c 6f 6f 70 20 28 hed)).. (loop ( 0380: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal 0390: 29 29 29 29 29 29 0a 0a 3b 3b 20 4d 6f 73 74 6c ))))))..;; Mostl 03a0: 79 20 77 6f 72 6b 65 64 20 3d 20 70 75 74 73 20 y worked = puts 03b0: 6f 75 74 20 61 6c 6c 20 63 6f 6d 62 69 6e 61 74 out all combinat 03c0: 69 6f 6e 73 3f 0a 28 64 65 66 69 6e 65 20 28 70 ions?.(define (p 03d0: 72 6f 63 65 73 73 2d 69 74 65 6d 6c 69 73 74 20 rocess-itemlist 03e0: 68 69 65 72 64 65 70 74 68 20 63 75 72 72 69 74 hierdepth currit 03f0: 65 6d 6b 65 79 20 69 74 65 6d 6c 69 73 74 29 0a emkey itemlist). 0400: 20 20 28 6c 65 74 20 28 28 72 65 73 20 27 28 29 (let ((res '() 0410: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not 0420: 68 69 65 72 64 65 70 74 68 29 0a 09 28 73 65 74 hierdepth)..(set 0430: 21 20 68 69 65 72 64 65 70 74 68 20 28 6c 65 6e ! hierdepth (len 0440: 67 74 68 20 69 74 65 6d 6c 69 73 74 29 29 29 0a gth itemlist))). 0450: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop (( 0460: 68 65 64 20 28 63 61 72 20 69 74 65 6d 6c 69 73 hed (car itemlis 0470: 74 29 29 0a 09 20 20 20 20 20 20 20 28 74 61 6c t)).. (tal 0480: 20 28 63 64 72 20 69 74 65 6d 6c 69 73 74 29 29 (cdr itemlist)) 0490: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c ). (if (nul 04a0: 6c 3f 20 74 61 6c 29 0a 09 20 20 28 66 6f 72 2d l? tal).. (for- 04b0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 69 74 each (lambda (it 04c0: 65 6d 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 em)... (if 04d0: 28 3e 20 28 6c 65 6e 67 74 68 20 63 75 72 72 69 (> (length curri 04e0: 74 65 6d 6b 65 79 29 20 28 2d 20 68 69 65 72 64 temkey) (- hierd 04f0: 65 70 74 68 20 32 29 29 0a 09 09 09 20 20 28 73 epth 2)).... (s 0500: 65 74 21 20 72 65 73 20 28 61 70 70 65 6e 64 20 et! res (append 0510: 72 65 73 20 28 6c 69 73 74 20 28 61 70 70 65 6e res (list (appen 0520: 64 20 63 75 72 72 69 74 65 6d 6b 65 79 20 28 6c d curritemkey (l 0530: 69 73 74 20 28 6c 69 73 74 20 28 63 61 72 20 68 ist (list (car h 0540: 65 64 29 20 69 74 65 6d 29 29 29 29 29 29 29 29 ed) item)))))))) 0550: 0a 09 09 20 20 20 20 28 63 61 64 72 20 68 65 64 ... (cadr hed 0560: 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 )).. (begin.. 0570: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam 0580: 62 64 61 20 28 69 74 65 6d 29 0a 09 09 09 28 73 bda (item)....(s 0590: 65 74 21 20 72 65 73 20 28 61 70 70 65 6e 64 20 et! res (append 05a0: 72 65 73 20 28 70 72 6f 63 65 73 73 2d 69 74 65 res (process-ite 05b0: 6d 6c 69 73 74 20 68 69 65 72 64 65 70 74 68 20 mlist hierdepth 05c0: 28 61 70 70 65 6e 64 20 63 75 72 72 69 74 65 6d (append curritem 05d0: 6b 65 79 20 28 6c 69 73 74 20 28 6c 69 73 74 20 key (list (list 05e0: 28 63 61 72 20 68 65 64 29 20 69 74 65 6d 29 29 (car hed) item)) 05f0: 29 20 74 61 6c 29 29 29 29 0a 09 09 20 20 20 20 ) tal))))... 0600: 20 20 28 63 61 64 72 20 68 65 64 29 29 0a 09 20 (cadr hed)).. 0610: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta 0620: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 0a l)(cdr tal))))). 0630: 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 69 res))..(defi 0640: 6e 65 20 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e ne (item-assoc-> 0650: 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 64 item-list itemsd 0660: 61 74 29 0a 20 20 28 69 66 20 28 61 6e 64 20 69 at). (if (and i 0670: 74 65 6d 73 64 61 74 20 28 6e 6f 74 20 28 6e 75 temsdat (not (nu 0680: 6c 6c 3f 20 69 74 65 6d 73 64 61 74 29 29 29 0a ll? itemsdat))). 0690: 20 20 20 20 20 20 28 6c 65 74 20 28 28 69 74 65 (let ((ite 06a0: 6d 6c 73 74 20 28 6d 61 70 20 28 6c 61 6d 62 64 mlst (map (lambd 06b0: 61 20 28 78 29 0a 09 09 09 20 20 20 20 28 6c 65 a (x).... (le 06c0: 74 20 28 28 6e 61 6d 65 20 28 63 61 72 20 78 29 t ((name (car x) 06d0: 29 0a 09 09 09 09 20 20 28 69 74 65 6d 73 20 28 )..... (items ( 06e0: 63 61 64 72 20 78 29 29 29 0a 09 09 09 20 20 20 cadr x))).... 06f0: 20 20 20 28 6c 69 73 74 20 6e 61 6d 65 20 28 73 (list name (s 0700: 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 74 65 6d tring-split item 0710: 73 29 29 29 29 0a 09 09 09 20 20 69 74 65 6d 73 s)))).... items 0720: 64 61 74 29 29 29 0a 09 28 70 72 6f 63 65 73 73 dat)))..(process 0730: 2d 69 74 65 6d 6c 69 73 74 20 23 66 20 27 28 29 -itemlist #f '() 0740: 20 69 74 65 6d 6c 73 74 29 29 0a 20 20 20 20 20 itemlst)). 0750: 20 27 28 28 29 29 29 29 20 3b 3b 20 72 65 74 75 '(()))) ;; retu 0760: 72 6e 20 61 20 6c 69 73 74 20 63 6f 6e 73 69 73 rn a list consis 0770: 74 69 6e 67 20 6f 6e 20 61 20 73 69 6e 67 6c 65 ting on a single 0780: 20 6e 75 6c 6c 20 6c 69 73 74 20 66 6f 72 20 6e null list for n 0790: 6f 6e 2d 69 74 65 6d 20 72 75 6e 73 0a 20 20 0a on-item runs. . 07a0: 28 64 65 66 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 (define-inline ( 07b0: 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 item-list->path 07c0: 69 74 65 6d 64 61 74 29 0a 20 20 28 73 74 72 69 itemdat). (stri 07d0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 20 ng-intersperse 07e0: 28 6d 61 70 20 63 61 64 72 20 69 74 65 6d 64 61 (map cadr itemda 07f0: 74 29 20 22 2f 22 29 29 0a 0a 3b 3b 20 28 70 70 t) "/"))..;; (pp 0800: 20 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e 69 74 (item-assoc->it 0810: 65 6d 2d 6c 69 73 74 20 69 74 65 6d 64 61 74 29 em-list itemdat) 0820: 29 0a 0a 0a 09 0a ).....