Changeset 27174 in project for release/4/tuples/trunk/tuples.scm


Ignore:
Timestamp:
08/03/12 12:11:06 (9 years ago)
Author:
juergen
Message:

version 0.8 with code split in two modules checked in

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/tuples/trunk/tuples.scm

    r26086 r27174  
    3333;         ju (at) jugilo (dot) de
    3434;
    35 ; Last update: Mar 07, 2012
     35; Last update: Aug 02, 2012
    3636;
    3737;In this module, we'll implement tuples, a container structure like
     
    5151;and couple-right.
    5252
    53 (require 'contracts)
    54 
    55 (module tuples ;*
     53(require-library contracts)
     54
     55(module %tuples
     56  (tuple tuple? tuple-length tuple-ref tuple-find
     57   tuple-map tuple-append list->tuple tuple->list tuple-for-each
     58   empty empty? single single? single-ref single-set! tuple-of?
     59   couple couple? couple-left couple-right triple triple? triple-left
     60   triple-middle triple-right tuple-left tuple-right tuple-copy)
     61 
     62(import scheme
     63        (only chicken unless condition-case case-lambda define-inline
     64          open-output-string get-output-string)
     65        (only data-structures list-of?))
     66
     67;;; implementation and helpers
     68;;; must appear before interface, because some routines are inlined
     69
     70(define-inline (project n)
     71  (lambda args
     72    (list-ref args n)))
     73
     74(define (tuple-length tup)
     75  (tup (project 1)))
     76
     77(define (tuple-ref tup n)
     78  (tup (project (+ n 2))))
     79
     80(define (tuple-left tup)
     81  (tup (project 2)))
     82
     83(define (tuple-right tup)
     84  (tup (project (+ (tuple-length tup) 1))))
     85
     86(define (tuple? xpr)
     87  (and (procedure? xpr)
     88       (condition-case (eq? 'tuple (xpr (project 0)))
     89         ((exn) #f))))
     90
     91(define (tuple-of? ok?)
     92  (lambda (x)
     93    (and (tuple? x)
     94         (let helper ((n (tuple-length x)))
     95           (if (zero? n)
     96             #t
     97             (and (ok? (tuple-ref 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 (tuple-map fn tup)
     104  (let loop ((n (tuple-length tup)) (acc '()))
     105    (if (zero? n)
     106      (apply tuple acc)
     107      (loop (- n 1) (cons (fn (tuple-ref tup (- n 1))) acc)))))
     108
     109(define (tuple-append . tups)
     110  (lambda (sel)
     111    (apply sel (cons 'tuple
     112                     (cons (apply + (map tuple-length tups))
     113                           (apply append (map tuple->list tups)))))))
     114
     115(define (tuple->list tup)
     116  (let loop ((n (tuple-length tup)) (acc '()))
     117    (if (zero? n)
     118      acc
     119      (loop (- n 1) (cons (tuple-ref tup (- n 1)) acc)))))
     120
     121(define (tuple-copy tup . intervall)
     122  (let (
     123    (from (if (null? intervall)
     124            0
     125            (car intervall)))
     126    (upto (if (< (length intervall) 2)
     127            (tuple-length tup)
     128            (cadr intervall)))
     129    )
     130    (let loop ((n upto) (acc '()))
     131      (if (= from n)
     132        (apply tuple acc)
     133        (loop (- n 1) (cons (tuple-ref tup (- n 1)) acc))))))
     134
     135(define (tuple-find tup item compare?)
     136  (let ((len (tuple-length tup)))
     137    (if (zero? len)
     138      #f
     139      (let loop ((result 0))
     140        (cond
     141          ((= result len) #f)
     142          ((compare? item (tuple-ref tup result)) result)
     143          (else (loop (+ result 1))))))))
     144
     145(define (tuple-for-each proc tup)
     146  (let ((len (tuple-length tup)))
     147    (let loop ((n 0))
     148      (unless (= n len)
     149        (proc (tuple-ref tup n))
     150        (loop (+ n 1))))))
     151
     152(define (list->tuple lst)
     153  (apply tuple lst))
     154
     155;;; empties are 0-tuples
     156(define (empty)
     157  (tuple))
     158
     159(define (empty? x)
     160  (and (tuple? x) (= (tuple-length x) 0)))
     161
     162;;; singles as mutable 1-tuples
     163(define (single? xpr)
     164  (and (procedure? xpr)
     165       (condition-case (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 (single-ref sg)
     174  (sg (project 1)))
     175
     176;;; command
     177(define (single-set! sg arg)
     178  ((sg (project 2)) arg))
     179
     180;;; couples are tuples which store two items
     181(define (couple? x)
     182  (and (tuple? x) (= (tuple-length x) 2)))
     183
     184(define (couple x y)
     185  (tuple 1 2))
     186
     187(define (couple-left tup)
     188  (tuple-ref tup 0))
     189
     190(define (couple-right tup)
     191  (tuple-ref tup 1))
     192
     193;;; triples are tuples which store three items
     194(define (triple? x)
     195  (and (tuple? x) (= (tuple-length x) 3)))
     196
     197(define (triple x y z)
     198  (tuple x y z))
     199
     200(define (triple-left tup)
     201  (tuple-ref tup 0))
     202
     203(define (triple-middle tup)
     204  (tuple-ref tup 1))
     205
     206(define (triple-right tup)
     207  (tuple-ref tup 2))
     208
     209) ; module %tuples
     210
     211(module tuples
    56212  (tuples tuple tuple? tuple-of? tuple-length tuple-ref tuple-find
    57213   tuple-map tuple-append list->tuple tuple->list tuple-for-each
     
    62218(import scheme
    63219        contracts
     220        (prefix %tuples %)
    64221        (only chicken unless condition-case case-lambda define-inline
    65222          open-output-string get-output-string)
     
    73230
    74231(define-inline (true? x) #t)
    75 
    76 (define-inline (project n)
    77   (lambda args
    78     (list-ref args n)))
    79 
    80 (define-inline (%tuple-length tup)
    81   (tup (project 1)))
    82 
    83 (define-inline (%tuple-ref tup n)
    84   (tup (project (+ n 2))))
    85 
    86 (define-inline (%tuple-left tup)
    87   (tup (project 2)))
    88 
    89 (define-inline (%tuple-right tup)
    90   (tup (project (+ (%tuple-length tup) 1))))
    91 
    92 (define-inline (%tuple-state sg)
    93   (sg (project 1)))
    94 
    95 (define-inline (%tuple-state! sg arg)
    96   ((sg (project 2)) arg))
    97 
    98 (define (%tuple? xpr)
    99   (and (procedure? xpr)
    100        (condition-case (eq? 'tuple (xpr (project 0)))
    101          ((exn) #f))))
    102 
    103 (define (%tuple-of? ok?)
    104   (lambda (x)
    105     (and (%tuple? x)
    106          (let helper ((n (%tuple-length x)))
    107            (if (zero? n)
    108              #t
    109              (and (ok? (%tuple-ref 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 (%tuple-map fn tup)
    116   (let loop ((n (%tuple-length tup)) (acc '()))
    117     (if (zero? n)
    118       (apply %tuple acc)
    119       (loop (- n 1) (cons (fn (%tuple-ref tup (- n 1))) acc)))))
    120 
    121 (define (%tuple-append . tups)
    122   (lambda (sel)
    123     (apply sel (cons 'tuple
    124                      (cons (apply + (map %tuple-length tups))
    125                            (apply append (map %tuple->list tups)))))))
    126 
    127 (define (%tuple->list tup)
    128   (let loop ((n (%tuple-length tup)) (acc '()))
    129     (if (zero? n)
    130       acc
    131       (loop (- n 1) (cons (%tuple-ref tup (- n 1)) acc)))))
    132 
    133 (define (%tuple-copy tup . intervall)
    134   (let (
    135     (from (if (null? intervall)
    136             0
    137             (car intervall)))
    138     (upto (if (< (length intervall) 2)
    139             (%tuple-length tup)
    140             (cadr intervall)))
    141     )
    142     (let loop ((n upto) (acc '()))
    143       (if (= from n)
    144         (apply %tuple acc)
    145         (loop (- n 1) (cons (%tuple-ref tup (- n 1)) acc))))))
    146 
    147 (define (%tuple-find tup item compare?)
    148   (let ((len (%tuple-length tup)))
    149     (if (zero? len)
    150       #f
    151       (let loop ((result 0))
    152         (cond
    153           ((= result len) #f)
    154           ((compare? item (%tuple-ref tup result)) result)
    155           (else (loop (+ result 1))))))))
    156 
    157 (define (%tuple-for-each proc tup)
    158   (let ((len (%tuple-length tup)))
    159     (let loop ((n 0))
    160       (unless (= n len)
    161         (proc (%tuple-ref tup n))
    162         (loop (+ n 1))))))
    163 
    164 (define (%single? xpr)
    165   (and (procedure? xpr)
    166        (condition-case (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 documentation
    174 (doclist '())
    175 
    176 ;;; iterface
    177 
    178 ;;; general n-tuples
    179232
    180233;;; predicates
     
    297350  "returns the state of the single object sg"
    298351  (domain (%single? sg))
    299   (%tuple-state sg))
     352  (%single-ref sg))
    300353
    301354;;; command
     
    303356  "replaces state of sg with arg"
    304357  (domain (%single? sg) (true? arg))
    305   (effect (state (%tuple-state sg) arg))
    306   (%tuple-state! sg arg))
     358  (effect (state (%single-ref sg) arg))
     359  (%single-set! sg arg))
    307360
    308361;;; couples are tuples which store two items
Note: See TracChangeset for help on using the changeset viewer.