Changeset 12854 in project


Ignore:
Timestamp:
12/19/08 15:39:01 (11 years ago)
Author:
felix winkelmann
Message:

ported to chicken 4

Location:
release/4/fps/trunk
Files:
1 added
7 edited
1 moved

Legend:

Unmodified
Added
Removed
  • release/4/fps/trunk/defrec.scm

    r9929 r12854  
    3838;;;   (employee:married? emp)
    3939;;;
    40 ;;; - Field-setting procedures:
     40;;; - Setter procedures:
    4141;;;   (set-employee:name emp "Janet Q. Random")
    4242;;;   (set-employee:id emp 8271)
     
    4646;;;   (set-employee:married? emp #t)
    4747;;;
    48 ;;; - Field-modifier procedures:
    49 ;;;   (modify-employee:salary emp (lambda (s) (* 1.03 s))) ; 3% raise
    50 ;;;   ...similarly for other fields.
    51 ;;;
    52 ;;; - Record-copy procedure:
    53 ;;;   (copy-employee emp) -> emp'
    54 ;;;
    5548;;; - A type predicate:
    5649;;;   (employee? x)
     
    6760;;;     y
    6861;;;     name
    69 ;;;     ((disclose self) (list "ship" (ship:name self))))
     62;;;     ((disclose self) (list (ship:name self))))
    7063;;; will cause (make-ship 10 20 "Valdez") to print as
    7164;;;   #{ship "Valdez"}
    7265
    73 ;;; Dependencies:
    74 ;;; - Code produced by the macro needs the RECORDS package.
    75 ;;; - Macro-expander code needs ERROR-PACKAGE and RECEIVING
     66(import-for-syntax (only chicken receive))
    7667
    77 (define-macro (define-record name . specs)
    78   (receive (field-specs method-specs)
    79       ;; Partition the field and method specs by form.
    80       (let lp ((specs (reverse specs))
    81                (fspecs '())
    82                (mspecs '()))
    83         (if (pair? specs)
    84             (let ((spec (car specs))
    85                   (specs (cdr specs)))
    86               (if (and (pair? spec) (pair? (car spec)))
    87                   ;; We only support the DISCLOSE method in S48.
    88                   (if (eq? (caar spec) 'disclose)
    89                       (lp specs fspecs (cons spec mspecs))
    90                       (error "Unsupported method in define-record." spec))
    91                   (lp specs (cons spec fspecs) mspecs)))
    92             (values fspecs mspecs)))
     68(define-syntax define-record
     69  (lambda (form rename compare)
     70    (receive (field-specs method-specs)
     71             ;; Partition the field and method specs by form.
     72             (let lp ((specs (reverse (cddr form)))
     73                      (fspecs '())
     74                      (mspecs '()))
     75               (if (pair? specs)
     76                   (let ((spec (car specs))
     77                         (specs (cdr specs)))
     78                     (if (and (pair? spec) (pair? (car spec)))
     79                        (if (eq? (caar spec) 'disclose)
     80                             (lp specs fspecs (cons spec mspecs))
     81                             (error "Unsupported method in define-record." spec))
     82                        (lp specs (cons spec fspecs) mspecs)))
     83                   (values fspecs mspecs)))
    9384
    94     (let* ((s->s symbol->string)
    95            (s-conc (lambda args (string->symbol (apply string-append args))))
    96            (spec-name (lambda (s) (if (pair? s) (car s) s)))
     85      (let* ((name (cadr form))
     86             (s->s symbol->string)
     87             (s-conc (lambda args (string->symbol (apply string-append args))))
     88             (spec-name (lambda (s) (if (pair? s) (car s) s)))
     89             (filter (lambda (pred lst)
     90                       (let f ((lst lst))
     91                         (if (pair? lst)
     92                             (let ((tail (f (cdr lst))))
     93                               (if (pred (car lst)) (cons (car lst) tail) tail))
     94                             '()))))
     95             (gensym (let ((j 0))
     96                       (lambda (s) (set! j (+ j 1))
     97                               (s-conc s (number->string j)))))
    9798
    98            (field-name (lambda (field-name)
    99                          (s-conc (s->s name) ":" (s->s field-name))))
    100            (set-name (lambda (field-name)
    101                        (s-conc "set-" (s->s name) ":" (s->s field-name))))
    102            (mod-name (lambda (field-name)
    103                        (s-conc "modify-" (s->s name) ":" (s->s field-name))))
    104            (copy-name (s-conc "copy-" (s->s name)))
    105            (pred-name (s-conc (s->s name) "?"))
    106            (maker-name (s-conc "make-" (s->s name)))
    107            (type-name (s-conc "type/" (s->s name)))
     99             (field-name (lambda (field-name)
     100                           (s-conc (s->s name) ":" (s->s field-name))))
     101             (set-name (lambda (field-name)
     102                         (s-conc "set-" (s->s name) ":" (s->s field-name))))
     103             (pred-name (s-conc (s->s name) "?"))
     104             (maker-name (s-conc "make-" (s->s name)))
     105             (type-name (s-conc "type/" (s->s name)))
    108106
    109            (fields (map spec-name field-specs))
    110            (param-fields (filter symbol? field-specs)) ; Args to maker proc.
    111            (default-field-specs (filter (lambda (fs) (and (pair? fs)
    112                                                           (pair? (cdr fs))))
    113                                         field-specs))
    114            (default-exps (map cadr default-field-specs))
    115            (rename identity)
    116            (param-vars (map (lambda (fs) (rename (gensym "field")))
    117                             param-fields))
     107             (fields (map spec-name field-specs))
     108             (param-fields (filter symbol? field-specs)) ; Args to maker proc.
     109             (default-field-specs (filter (lambda (fs) (and (pair? fs)
     110                                                            (pair? (cdr fs))))
     111                                          field-specs))
     112             (default-exps (map cadr default-field-specs))
     113             (param-vars (map (lambda (fs) (rename (gensym "field")))
     114                              param-fields))
    118115
    119            (maker (gensym)))
     116             (maker (rename 'maker))
     117             (%make-record-type   (rename 'make-record-type))
     118             (%record-constructor (rename 'record-constructor))
     119             (%record-predicate   (rename 'record-predicate))
     120             (%record-accessor    (rename 'record-accessor))
     121             (%record-modifier    (rename 'record-modifier))
     122             (%unspecified        (rename 'void))
     123             (%define             (rename 'define))
     124             (%let                (rename 'let))
     125             (%lambda             (rename 'lambda))
     126             (%begin              (rename 'begin)))
    120127
    121       `(begin
    122          (define ,type-name
    123            (make-record-type ',name ',fields))
     128        `(,%begin
     129          (,%define ,type-name
     130            (,%make-record-type ,(s->s name) ',fields))
    124131
    125          ;; Maker proc (MAKE-EMPLOYEE name id-number sex married?)
    126          (define ,maker-name
    127            ,(if (null? default-field-specs)
    128                 ;; Gratuitous optimisation:
    129                 `(record-constructor ,type-name ',param-fields)
    130                
    131                 ;; Full-blown form.
    132                 `(let ((,maker (record-constructor
    133                                 ,type-name
    134                                 ',(append param-fields
    135                                           (map spec-name
    136                                                default-field-specs)))))
    137                    (lambda ,param-vars
    138                      (,maker ,@param-vars ,@default-exps)))))
     132          ;; Maker proc (MAKE-EMPLOYEE name id-number sex married?)
     133          (,%define ,maker-name
     134            ,(if (null? default-field-specs)
     135                 ;; Gratuitous optimisation:
     136                 `(,%record-constructor ,type-name ',param-fields)
     137             
     138                 ;; Full-blown form.
     139                 `(,%let ((,maker (,%record-constructor
     140                                   ,type-name
     141                                   ',(append param-fields
     142                                             (map spec-name
     143                                                  default-field-specs)))))
     144                         (,%lambda ,param-vars
     145                           (,maker ,@param-vars ,@default-exps)))))
    139146
    140          ;; Type predicate (EMPLOYEE? x)
    141          (define ,pred-name (record-predicate ,type-name))
     147          ;; Type predicate (EMPLOYEE? x)
     148          (,%define ,pred-name (,%record-predicate ,type-name))
    142149       
    143          ;; Accessors (EMPLOYEE:NAME emp), ...
    144          ,@(map (lambda (field)
    145                   `(define ,(field-name field)
    146                      (record-accessor ,type-name ',field)))
    147                 fields)
     150          ;; Accessors (EMPLOYEE:NAME emp), ...
     151          ,@(map (lambda (spec)
     152                   `(,%define ,(field-name (spec-name spec))
     153                      (,%record-accessor ,type-name ',(spec-name spec))))
     154                 field-specs)
    148155
    149          ;; Field setters (SET-EMPLOYEE:NAME emp name), ...
    150          ,@(map (lambda (field)
    151                   `(define ,(set-name field)
    152                      (record-modifier ,type-name ',field)))
    153                 fields)
     156          ;; Setters (SET-EMPLOYEE:NAME emp name), ...
     157          ,@(map (lambda (spec)
     158                   `(,%define ,(set-name (spec-name spec))
     159                      (,%record-modifier ,type-name ',(spec-name spec))))
     160                 field-specs)
    154161
    155          ;; Field modifiers (MODIFY-EMPLOYEE:NAME emp proc), ...
    156          ,@(let ((%setter (gensym 'setter))  ; set-ship:name
    157                 (%rec    (gensym 'r)) ; parameter: record to be modified.
    158                 (%proc   (gensym 'proc))) ; parameter: modifying procedure.
    159              (map (lambda (field)
    160                     (let ((%setter-proc `(record-modifier ,type-name
    161                                                           ',field))
    162                           (%sel-proc `(record-accessor ,type-name ',field))
    163                           (%selector (gensym 'getter)))
    164                       `(define ,(mod-name field)
    165                          (let ((,%setter ,%setter-proc)
    166                                (,%selector ,%sel-proc))
    167                            (lambda (,%rec ,%proc)
    168                              (,%setter ,%rec (,%proc (,%selector ,%rec))))))))
    169                   fields))
    170 
    171          ;; Record copy procedure
    172          ,(let ((%rec (gensym 'r))
    173                 (accessors (map (lambda (f) (gensym "f")) fields)))
    174             `(define ,copy-name
    175                (let ((,maker (record-constructor ,type-name ',fields))
    176                      . ,(map (lambda (field accessor)
    177                                `(,accessor (record-accessor ,type-name
    178                                                             ',field)))
    179                              fields accessors))
    180                  (lambda (,%rec)
    181                    (,maker . ,(map (lambda (a) `(,a ,%rec)) accessors))))))
    182 
    183         ))))
     162          )))))
  • release/4/fps/trunk/exports.scm

    r9929 r12854  
    1 ;;;; exports.scm
    2 
    3 
    4 (declare
    5   (export
    6    fps:pi fps:1/4pi fps:1/2pi fps:3/4pi fps:5/4pi fps:3/2pi fps:7/4pi fps:2pi
    7    fps:origin
    8    fps:identity-matrix
    9    fps:afm-directory-list
    10 
    11    ;; font
    12    fps:font?
    13    fps:font
    14 
    15    ;; Point and Matrix
    16    fps:pt? fps:pt=
    17    fps:pt fps:pt:x fps:pt:y
    18    fps:add-pts  fps:negate-pt  fps:scale-pt
    19 
    20    fps:matrix? fps:matrix=
    21    fps:matrix fps:matrix*
    22 
    23    ;; Path Makers
    24    fps:path?
    25    fps:line
    26    fps:rect
    27    fps:arc
    28    fps:tangent-arc
    29    fps:curve
    30    fps:close-path
    31    fps:stroke-outline-path
    32    fps:bitmap->path
    33    fps:bounding-box->rect
    34    fps:the-empty-path
    35 
    36    ;; glyphs construction
    37    fps:char->glyphpath
    38    fps:int->glyphpath
    39    fps:glyphname->glyphpath
    40    fps:vector->glyphpath
    41    fps:simple-string->glyphpath
    42    fps:string->glyphpath
    43 
    44    ;; Picture Makers
    45    fps:picture?
    46    fps:stroke fps:fill fps:clip fps:colormap fps:bitmap->pict
    47    fps:paint-glyphpath
    48    fps:the-empty-pict
    49 
    50    ;; combination
    51    fps:compose       fps:compose-path   fps:compose-pict
    52    fps:join          fps:join-path      fps:join-pict
    53    fps:link
    54 
    55    ;; transformation
    56    fps:translate fps:rotate fps:scale
    57 
    58    ;; style
    59    fps:style?
    60    fps:vary-default
    61    fps:build-style       
    62    fps:with-style*
    63    fps:default-style
    64 
    65    ;; attributes
    66    fps:attrib?
    67    fps::color        fps::line-cap     fps::line-width
    68    fps::dash-pattern fps::dash-offset 
    69    fps::line-join    fps::miter-limit
    70 
    71    ;; colors
    72    fps:color?   fps:color=
    73    fps:gray     fps:gray:val
    74    fps:rgb      fps:rgb:r  fps:rgb:g  fps:rgb:b
    75    fps:hsb      fps:hsb:h  fps:hsb:s  fps:hsb:b
    76    fps:cmyk     fps:cmyk:c fps:cmyk:m fps:cmyk:y fps:cmyk:k
    77 
    78    ;; char map
    79    fps:char-map?
    80    fps:base-char-map
    81    fps:lookup-char-map
    82    fps:function->char-map
    83    fps:alist->char-map
    84    fps:mask-char-map
    85    fps:native-font-char-map
    86 
    87    ;; int map
    88    fps:int-map?
    89    fps:base-int-map
    90    fps:lookup-int-map
    91    fps:function->int-map
    92    fps:alist->int-map
    93    fps:mask-int-map
    94    fps:native-font-int-map
    95 
    96    ;; object info
    97    fps:start-pt     
    98    fps:end-pt
    99    fps:bounding-box 
    100    fps:bounding-box:max fps:bounding-box:min
    101 
    102    ;; channel
    103    fps:channel?
    104    fps:show
    105    fps:show-w/ps2-text-channel
    106    fps:ps2-text-channel
    107    fps:close-channel
    108 
    109    ;; bitmap
    110    fps:bitmap?
    111    fps:vector->bitmap
    112    fps:hex-string->bitmap
    113    fps:bin-string->bitmap
    114 
    115    ;; options
    116    fps::format
    117    fps::creator      fps::creation-date  fps::title
    118    fps::copyright    fps::for            fps::routing
    119    fps::duplex       fps::duplex-tumble  fps::collate 
    120    fps::num-copies   fps::orientation
    121    fps::page-label
    122 
    123    ;; util
    124    fps:deg->rad fps:rad->deg
    125    fps:inch
    126 
    127    ;; faked syntax-case module...
    128    fps$$pi fps$$1/4pi fps$$1/2pi fps$$3/4pi fps$$5/4pi fps$$3/2pi fps$$7/4pi fps$$2pi
    129    fps$$origin
    130    fps$$identity-matrix
    131    fps$$afm-directory-list
    132 
    133    ;; font
    134    fps$$font?
    135    fps$$font
    136 
    137    ;; Point and Matrix
    138    fps$$pt? fps$$pt=
    139    fps$$pt fps$$pt:x fps$$pt:y
    140    fps$$add-pts  fps$$negate-pt  fps$$scale-pt
    141 
    142    fps$$matrix? fps$$matrix=
    143    fps$$matrix fps$$matrix*
    144 
    145    ;; Path Makers
    146    fps$$path?
    147    fps$$line
    148    fps$$rect
    149    fps$$arc
    150    fps$$tangent-arc
    151    fps$$curve
    152    fps$$close-path
    153    fps$$stroke-outline-path
    154    fps$$bitmap->path
    155    fps$$bounding-box->rect
    156    fps$$the-empty-path
    157 
    158    ;; glyphs construction
    159    fps$$char->glyphpath
    160    fps$$int->glyphpath
    161    fps$$glyphname->glyphpath
    162    fps$$vector->glyphpath
    163    fps$$simple-string->glyphpath
    164    fps$$string->glyphpath
    165 
    166    ;; Picture Makers
    167    fps$$picture?
    168    fps$$stroke fps$$fill fps$$clip fps$$colormap fps$$bitmap->pict
    169    fps$$paint-glyphpath
    170    fps$$the-empty-pict
    171 
    172    ;; combination
    173    fps$$compose       fps$$compose-path   fps$$compose-pict
    174    fps$$join          fps$$join-path      fps$$join-pict
    175    fps$$link
    176 
    177    ;; transformation
    178    fps$$translate fps$$rotate fps$$scale
    179 
    180    ;; style
    181    fps$$style?
    182    fps$$vary-default
    183    fps$$build-style       
    184    fps$$with-style*
    185 
    186    ;; attributes
    187    fps$$attrib?
    188    fps$$:color        fps$$:line-cap     fps$$:line-width
    189    fps$$:dash-pattern fps$$:dash-offset 
    190    fps$$:line-join    fps$$:miter-limit
    191 
    192    ;; colors
    193    fps$$color?   fps$$color=
    194    fps$$gray     fps$$gray:val
    195    fps$$rgb      fps$$rgb:r  fps$$rgb:g  fps$$rgb:b
    196    fps$$hsb      fps$$hsb:h  fps$$hsb:s  fps$$hsb:b
    197    fps$$cmyk     fps$$cmyk:c fps$$cmyk:m fps$$cmyk:y fps$$cmyk:k
    198 
    199    ;; char map
    200    fps$$char-map?
    201    fps$$base-char-map
    202    fps$$lookup-char-map
    203    fps$$function->char-map
    204    fps$$alist->char-map
    205    fps$$mask-char-map
    206    fps$$native-font-char-map
    207 
    208    ;; int map
    209    fps$$int-map?
    210    fps$$base-int-map
    211    fps$$lookup-int-map
    212    fps$$function->int-map
    213    fps$$alist->int-map
    214    fps$$mask-int-map
    215    fps$$native-font-int-map
    216 
    217    ;; object info
    218    fps$$start-pt     
    219    fps$$end-pt
    220    fps$$bounding-box 
    221    fps$$bounding-box:max fps$$bounding-box:min
    222 
    223    ;; channel
    224    fps$$channel?
    225    fps$$show
    226    fps$$show-w/ps2-text-channel
    227    fps$$ps2-text-channel
    228    fps$$close-channel
    229 
    230    ;; bitmap
    231    fps$$bitmap?
    232    fps$$vector->bitmap
    233    fps$$hex-string->bitmap
    234    fps$$bin-string->bitmap
    235 
    236    ;; options
    237    fps$$:format
    238    fps$$:creator      fps$$:creation-date  fps$$:title
    239    fps$$:copyright    fps$$:for            fps$$:routing
    240    fps$$:duplex       fps$$:duplex-tumble  fps$$:collate 
    241    fps$$:num-copies   fps$$:orientation
    242    fps$$:page-label
    243 
    244    ;; util
    245    fps$$deg->rad fps$$rad->deg
    246    fps$$inch
    247    ) )
    248 
    249 (define fps:pi pi)
    250 (define fps:1/4pi 1/4pi)
    251 (define fps:1/2pi 1/2pi)
    252 (define fps:3/4pi 3/4pi)
    253 (define fps:5/4pi 5/4pi)
    254 (define fps:3/2pi 3/2pi)
    255 (define fps:7/4pi 7/4pi)
    256 (define fps:2pi 2pi)
    257 (define fps:origin origin)
    258 (define fps:identity-matrix identity-matrix)
    259 (define fps:afm-directory-list afm-directory-list)
    260 
    261 ;; font
    262 (define fps:font? font?)
    263 (define fps:font font)
    264 
    265 ;; Point and Matrix
    266 (define fps:pt? pt?) (define fps:pt= pt=)
    267 (define fps:pt pt) (define fps:pt:x pt:x) (define fps:pt:y pt:y)
    268 (define fps:add-pts add-pts)  (define fps:negate-pt negate-pt)  (define fps:scale-pt scale-pt)
    269 
    270 (define fps:matrix? matrix?) (define fps:matrix= matrix=)
    271 (define fps:matrix matrix) (define fps:matrix* matrix*)
    272 
    273 ;; Path Makers
    274 (define fps:path? path?)
    275 (define fps:line line)
    276 (define fps:rect rect)
    277 (define fps:arc arc)
    278 (define fps:tangent-arc tangent-arc)
    279 (define fps:curve curve)
    280 (define fps:close-path close-path)
    281 (define fps:stroke-outline-path stroke-outline-path)
    282 (define fps:bitmap->path bitmap->path)
    283 (define fps:bounding-box->rect bounding-box->rect)
    284 (define fps:the-empty-path the-empty-path)
    285 
    286 ;; glyphs construction
    287 (define fps:char->glyphpath char->glyphpath)
    288 (define fps:int->glyphpath int->glyphpath)
    289 (define fps:glyphname->glyphpath glyphname->glyphpath)
    290 (define fps:vector->glyphpath vector->glyphpath)
    291 (define fps:simple-string->glyphpath simple-string->glyphpath)
    292 (define fps:string->glyphpath string->glyphpath)
    293 
    294 ;; Picture Makers
    295 (define fps:picture? picture?)
    296 (define fps:stroke stroke)
    297 (define fps:fill fill) (define fps:clip clip) (define fps:colormap colormap) (define fps:bitmap->pict bitmap->pict)
    298 (define fps:paint-glyphpath paint-glyphpath)
    299 (define fps:the-empty-pict the-empty-pict)
    300 
    301 ;; combination
    302 (define fps:compose compose)       (define fps:compose-path compose-path)   (define fps:compose-pict compose-pict)
    303 (define fps:join join)          (define fps:join-path join-path)      (define fps:join-pict join-pict)
    304 (define fps:link link)
    305 
    306 ;; transformation
    307 (define fps:translate translate) (define fps:rotate rotate) (define fps:scale scale)
    308 
    309 ;; style
    310 (define fps:style? style?)
    311 (define fps:vary-default vary-default)
    312 (define fps:build-style build-style)     
    313 (define fps:with-style* with-style*)
    314 (define fps:default-style default-style)
    315 
    316 ;; attributes
    317 (define fps:attrib? attrib?)
    318 (define fps::color :color)        (define fps::line-cap :line-cap)     (define fps::line-width :line-width)
    319 (define fps::dash-pattern :dash-pattern) (define fps::dash-offset :dash-offset) 
    320 (define fps::line-join :line-join)    (define fps::miter-limit :miter-limit)
    321 
    322 ;; colors
    323 (define fps:color? color?)   (define fps:color= color=)
    324 (define fps:gray gray)     (define fps:gray:val gray:val)
    325 (define fps:rgb rgb)      (define fps:rgb:r rgb:r)  (define fps:rgb:g rgb:g)  (define fps:rgb:b rgb:b)
    326 (define fps:hsb hsb)      (define fps:hsb:h hsb:h)  (define fps:hsb:s hsb:s)  (define fps:hsb:b hsb:b)
    327 (define fps:cmyk cmyk)     (define fps:cmyk:c cmyk:c) (define fps:cmyk:m cmyk:m) (define fps:cmyk:y cmyk:y) (define fps:cmyk:k cmyk:k)
    328 
    329 ;; char map
    330 (define fps:char-map? char-map?)
    331 (define fps:base-char-map base-char-map)
    332 (define fps:lookup-char-map lookup-char-map)
    333 (define fps:function->char-map function->char-map)
    334 (define fps:alist->char-map alist->char-map )
    335 (define fps:mask-char-map mask-char-map)
    336 (define fps:native-font-char-map native-font-char-map)
    337 
    338 ;; int map
    339 (define fps:int-map? int-map?)
    340 (define fps:base-int-map base-int-map)
    341 (define fps:lookup-int-map lookup-int-map)
    342 (define fps:function->int-map function->int-map)
    343 (define fps:alist->int-map alist->int-map)
    344 (define fps:mask-int-map mask-int-map)
    345 (define fps:native-font-int-map native-font-int-map)
    346 
    347 ;; object info
    348 (define fps:start-pt start-pt)     
    349 (define fps:end-pt end-pt)
    350 (define fps:bounding-box bounding-box) 
    351 (define fps:bounding-box:max bounding-box:max) (define fps:bounding-box:min bounding-box:min)
    352 
    353 ;; channel
    354 (define fps:channel? channel?)
    355 (define fps:show show)
    356 (define fps:show-w/ps2-text-channel show-w/ps2-text-channel)
    357 (define fps:ps2-text-channel ps2-text-channel)
    358 (define fps:close-channel close-channel)
    359 
    360 ;; bitmap
    361 (define fps:bitmap? bitmap?)
    362 (define fps:vector->bitmap vector->bitmap)
    363 (define fps:hex-string->bitmap hex-string->bitmap)
    364 (define fps:bin-string->bitmap bin-string->bitmap)
    365 
    366 ;; options
    367 (define fps::format :format)
    368 (define fps::creator :creator)      (define fps::creation-date :creation-date)  (define fps::title :title)
    369 (define fps::copyright :copyright)    (define fps::for :for)            (define fps::routing :routing)
    370 (define fps::duplex :duplex)       (define fps::duplex-tumble :duplex-tumble)  (define fps::collate :collate) 
    371 (define fps::num-copies :num-copies)   (define fps::orientation :orientation)
    372 (define fps::page-label :page-label)
    373 
    374 ;; util
    375 (define fps:deg->rad deg->rad) (define fps:rad->deg rad->deg)
    376 (define fps:inch inch)
  • release/4/fps/trunk/fps-base.scm

    r10062 r12854  
    1 ;;;; fps-base.scm
    2 
    3 (use srfi-1)  ;; for filter
    4 (use srfi-69) ;; for hash-table
    5 (use regex)   ;; for string-split-fields
    6 
    7 (use syntax-case)
    8 (use records utils format-modular)
    9 
    10 (define (field-splitter rx)
    11   (lambda (str #!optional (start 0))
    12     (string-split-fields rx str #t start) ) )
    13 
    14 (define (infix-splitter rx)
    15   (lambda (str #!optional (start 0))
    16     (string-split-fields rx str #:infix start) ) )
    17 
    18 (define (suffix-splitter rx)
    19   (lambda (str #!optional (start 0))
    20     (string-split-fields rx str #:suffix start) ) )
    21 
    22 (define char->ascii char->integer)
    23 (define ascii->char integer->char)
    24 
    25 (define (make-string-table) (make-hash-table string=?))
    26 (define table-ref (cut hash-table-ref/default <> <> #f))
    27 (define table-set! hash-table-set!)
    28 
    29 (include "conditionals")
    30 (include "defrec")
    31 (include "fps.type")
    32 (include "fps.color")
    33 (include "fps.util")
    34 (include "fps-global")
    35 (include "fps.glyph")
    36 (include "fps.comp")
    37 (include "fps.paint")
    38 (include "fps.map")
    39 (include "fps.afm")
    40 (include "fps.ask")
    41 (include "fps.show")
    42 (include "fps.mat")
    43 (include "fps.style")
    44 (include "fps.bitmap")
    45 (include "fps.options")
    46 (include "ps.path")
    47 (include "ps.misc")
    48 (include "exports")
    49 
    50 (define-record-printer (pt p port)
    51   (format port "#<pt ~s/~s>" (pt:x p) (pt:y p)))
    52 
    53 (provide 'fps-base)
    54 (include "fps")
  • release/4/fps/trunk/fps.exports

    r9929 r12854  
    1 fps$$negate-pt
    2 fps:negate-pt
    3 fps$$matrix
    4 fps$$:for
    5 fps$$join-path
    6 fps:join-path
    7 fps:join
    8 fps$$:copyright
    9 fps::copyright
    10 fps$$bounding-box:max
    11 fps:bounding-box:max
    12 fps:path?
    13 fps:rect
    14 fps:fill
    15 fps$$:routing
    16 fps::routing
    17 fps$$bounding-box:min
    18 fps:bounding-box:min
    19 fps:pi
    20 fps:pt
    21 fps:pt=
    22 fps:pt?
    23 fps$$origin
    24 fps:matrix*
    25 fps:matrix=
    26 fps:matrix?
    27 fps:3/2pi
    28 fps$$bitmap->path
    29 fps:bitmap->path
    30 fps$$the-empty-path
    31 fps:the-empty-path
    32 fps:gray
    33 fps:hsb:b
    34 fps:hsb:h
    35 fps:rgb:b
    36 fps:rgb:g
    37 fps:hsb:s
    38 fps:rgb:r
    39 fps$$pt=
    40 fps$$pt?
    41 fps$$5/4pi
    42 fps$$channel?
    43 fps:channel?
    44 fps:end-pt
    45 fps$$:miter-limit
    46 fps::miter-limit
    47 fps:cmyk:c
    48 fps$$add-pts
    49 fps:cmyk:k
    50 fps:cmyk:m
    51 fps:default-style
    52 fps:cmyk:y
    53 fps$$translate
    54 fps:translate
    55 fps:rgb
    56 fps:clip
    57 fps$$bitmap?
    58 fps$$:title
    59 fps$$:line-cap
    60 fps::line-cap
    61 fps$$join
    62 fps:matrix
    63 fps::format
    64 fps$$gray:val
    65 fps:gray:val
    66 fps$$:num-copies
    67 fps::num-copies
    68 fps:line
    69 fps:attrib?
    70 fps$$path?
    71 fps:link
    72 fps$$rect
    73 fps$$rgb
    74 fps:3/4pi
    75 fps$$fill
    76 fps$$:line-width
    77 fps::line-width
    78 fps$$alist->int-map
    79 fps$$function->int-map
    80 fps:alist->int-map
    81 fps:function->int-map
    82 fps:compose
    83 fps$$3/2pi
    84 fps$$:duplex
    85 fps:font?
    86 fps$$compose-pict
    87 fps:compose-pict
    88 fps:origin
    89 fps$$hsb:b
    90 fps$$hsb:h
    91 fps$$rgb:b
    92 fps$$rgb:g
    93 fps$$hsb:s
    94 fps$$rgb:r
    95 fps$$gray
    96 fps$$rotate
    97 fps:curve
    98 fps:cmyk
    99 fps:pt:x
    100 fps:pt:y
    101 fps$$stroke
    102 fps$$colormap
    103 fps:colormap
    104 fps:hsb
    105 fps$$clip
    106 fps:1/2pi
    107 fps$$:dash-pattern
    108 fps::dash-pattern
    109 fps$$matrix*
    110 fps$$matrix=
    111 fps$$matrix?
    112 fps$$native-font-char-map
    113 fps$$mask-char-map
    114 fps$$alist->char-map
    115 fps$$function->char-map
    116 fps$$lookup-char-map
    117 fps$$base-char-map
    118 fps:native-font-char-map
    119 fps:mask-char-map
    120 fps:alist->char-map
    121 fps:function->char-map
    122 fps:lookup-char-map
    123 fps:base-char-map
    124 fps::title
    125 fps$$start-pt
    126 fps:start-pt
    127 fps$$line
    128 fps$$link
    129 fps$$color=
    130 fps$$hsb
    131 fps$$color?
    132 fps$$3/4pi
    133 fps$$:color
    134 fps$$with-style*
    135 fps:with-style*
    136 fps$$build-style
    137 fps:build-style
    138 fps$$close-channel
    139 fps$$ps2-text-channel
    140 fps$$show-w/ps2-text-channel
    141 fps:close-channel
    142 fps:ps2-text-channel
    143 fps:show-w/ps2-text-channel
    144 fps$$:orientation
    145 fps::orientation
    146 fps:inch
    147 fps$$:creation-date
    148 fps::creation-date
    149 fps$$font?
    150 fps$$pi
    151 fps$$pt
    152 fps$$curve
    153 fps$$:duplex-tumble
    154 fps::duplex-tumble
    155 fps:font
    156 fps$$:page-label
    157 fps::page-label
    158 fps$$attrib?
    159 fps$$afm-directory-list
    160 fps:afm-directory-list
    161 fps$$join-pict
    162 fps:join-pict
    163 fps$$cmyk
    164 fps:1/4pi
    165 fps$$pt:x
    166 fps$$pt:y
    167 fps:rotate
    168 fps:7/4pi
    169 fps:stroke
    170 fps$$style?
    171 fps$$:line-join
    172 fps::line-join
    173 fps$$1/2pi
    174 fps$$native-font-int-map
    175 fps$$mask-int-map
    176 fps$$lookup-int-map
    177 fps$$base-int-map
    178 fps:native-font-int-map
    179 fps:mask-int-map
    180 fps:lookup-int-map
    181 fps:base-int-map
    182 fps$$compose
    183 fps::duplex
    184 fps$$stroke-outline-path
    185 fps:stroke-outline-path
    186 fps$$int-map?
    187 fps:int-map?
    188 fps:scale
    189 fps$$bitmap->pict
    190 fps:bitmap->pict
    191 fps$$the-empty-pict
    192 fps:the-empty-pict
    193 fps:show
    194 fps:color=
    195 fps:color?
    196 fps$$compose-path
    197 fps$$close-path
    198 fps:compose-path
    199 fps:close-path
    200 fps$$deg->rad
    201 fps:deg->rad
    202 fps$$inch
    203 fps::color
    204 fps::for
    205 fps$$scale-pt
    206 fps:scale-pt
    207 fps$$:creator
    208 fps::creator
    209 fps$$bounding-box->rect
    210 fps:bounding-box->rect
    211 fps:2pi
    212 fps$$bin-string->bitmap
    213 fps$$hex-string->bitmap
    214 fps$$vector->bitmap
    215 fps:bin-string->bitmap
    216 fps:hex-string->bitmap
    217 fps:vector->bitmap
    218 fps$$font
    219 fps:arc
    220 fps$$1/4pi
    221 fps$$:dash-offset
    222 fps::dash-offset
    223 fps$$:collate
    224 fps::collate
    225 fps:add-pts
    226 fps$$7/4pi
    227 fps$$rad->deg
    228 fps:rad->deg
    229 fps$$char-map?
    230 fps:char-map?
    231 fps$$picture?
    232 fps:picture?
    233 fps$$identity-matrix
    234 fps:identity-matrix
    235 fps$$2pi
    236 fps:bitmap?
    237 fps$$tangent-arc
    238 fps:tangent-arc
    239 fps$$arc
    240 fps:style?
    241 fps$$bounding-box
    242 fps:bounding-box
    243 fps$$:format
    244 fps$$scale
    245 fps$$vary-default
    246 fps:vary-default
    247 fps$$end-pt
    248 fps$$cmyk:c
    249 fps$$paint-glyphpath
    250 fps$$string->glyphpath
    251 fps$$simple-string->glyphpath
    252 fps$$vector->glyphpath
    253 fps$$glyphname->glyphpath
    254 fps$$int->glyphpath
    255 fps$$char->glyphpath
    256 fps:paint-glyphpath
    257 fps:string->glyphpath
    258 fps:simple-string->glyphpath
    259 fps:vector->glyphpath
    260 fps:glyphname->glyphpath
    261 fps:int->glyphpath
    262 fps:char->glyphpath
    263 fps$$cmyk:k
    264 fps$$cmyk:m
    265 fps$$cmyk:y
    266 fps:5/4pi
    267 fps$$show
  • release/4/fps/trunk/fps.meta

    r9929 r12854  
    1 ;;; fps.meta -*- Hen -*-
     1;;; fps.meta -*- Scheme -*-
    22
    33((egg "fps.egg")
    44 (synopsis "Functional PostScript")
    5  (needs syntax-case records format-modular)
     5 (needs records format)
    66 (category graphics)
    77 (doc-from-wiki)
    88 (license "Free Use")
    99 (author "Wandy Sae-Tan and Olin Shivers")
    10  (files "fps.setup" "fps.scm" "fps.html"
     10 (files "fps.setup" "fps.scm"
    1111        "fps.mat.scm" "fps-base.scm"
    1212        "AFM/" "fps-ref.txt" "fps.options.scm"
    1313        "fps-tutorial.txt" "fps.paint.scm"
    14         "fps.afm.scm"
     14        "fps.afm.scm" "tests"
    1515        "conditionals.scm" "fps.ask.scm" "fps.setup"
    1616        "defrec.scm" "fps.bitmap.scm" "fps.show.scm"
    1717        "fps.color.scm" "fps.style.scm"
    1818        "exports.scm" "fps.comp.scm" "fps.type.scm"
    19         "fps-examples.scm" "fps.exports" "fps.util.scm"
     19        "fps.exports" "fps.util.scm"
    2020        "fps-global.scm" "fps.glyph.scm" "ps.misc.scm"
    2121        "fps.map.scm" "ps.path.scm"))
  • release/4/fps/trunk/fps.scm

    r9929 r12854  
    1 ;;;; fps.scm - a faked syntax-case module
     1;;;; fps.scm
    22
    3 (cond-expand
    4  (syntax-case
    5      (require 'fps-base)
     3(module fps
     4    ( ;; constants
     5     pi 1/4pi 1/2pi 3/4pi 5/4pi 3/2pi 7/4pi 2pi
     6     origin
     7     identity-matrix
     8     afm-directory-list
    69
    7      (module fps
    8          (;; constants
    9           pi 1/4pi 1/2pi 3/4pi 5/4pi 3/2pi 7/4pi 2pi
    10              origin
    11              identity-matrix
    12              afm-directory-list
     10     ;; font
     11     font?
     12     font
    1313
    14              ;; font
    15              font?
    16              font
     14     ;; Point and Matrix
     15     pt? pt=
     16     pt pt:x pt:y
     17     add-pts  negate-pt  scale-pt
    1718
    18              ;; Point and Matrix
    19              pt? pt=
    20              pt pt:x pt:y
    21              add-pts  negate-pt  scale-pt
     19     matrix? matrix=
     20     matrix matrix*
    2221
    23              matrix? matrix=
    24              matrix matrix*
     22     ;; Path Makers
     23     path?
     24     line
     25     rect
     26     arc
     27     tangent-arc
     28     curve
     29     close-path
     30     stroke-outline-path
     31     bitmap->path
     32     bounding-box->rect
     33     the-empty-path
    2534
    26              ;; Path Makers
    27              path?
    28              line
    29              rect
    30              arc
    31              tangent-arc
    32              curve
    33              close-path
    34              stroke-outline-path
    35              bitmap->path
    36              bounding-box->rect
    37              the-empty-path
     35     ;; glyphs construction
     36     char->glyphpath
     37     int->glyphpath
     38     glyphname->glyphpath
     39     vector->glyphpath
     40     simple-string->glyphpath
     41     string->glyphpath
    3842
    39              ;; glyphs construction
    40              char->glyphpath
    41              int->glyphpath
    42              glyphname->glyphpath
    43              vector->glyphpath
    44              simple-string->glyphpath
    45              string->glyphpath
     43     ;; Picture Makers
     44     picture?
     45     stroke fill clip colormap bitmap->pict
     46     paint-glyphpath
     47     the-empty-pict
    4648
    47              ;; Picture Makers
    48              picture?
    49              stroke fill clip colormap bitmap->pict
    50              paint-glyphpath
    51              the-empty-pict
     49     ;; combination
     50     compose       compose-path   compose-pict
     51     join          join-path      join-pict
     52     link
    5253
    53              ;; combination
    54              compose       compose-path   compose-pict
    55              join          join-path      join-pict
    56              link
     54     ;; transformation
     55     translate rotate scale
    5756
    58              ;; transformation
    59              translate rotate scale
     57     ;; style
     58     style?
     59     vary-default
     60     build-style         
     61     with-style*
     62     with-style
     63     (with-attrib default-style)
    6064
    61              ;; style
    62              style?
    63              vary-default
    64              build-style         
    65              with-style*
    66              with-style
    67              with-attrib
     65     ;; attributes
     66     attrib?
     67     :color        :line-cap     :line-width
     68     :dash-pattern :dash-offset 
     69     :line-join    :miter-limit
    6870
    69              ;; attributes
    70              attrib?
    71              :color        :line-cap     :line-width
    72              :dash-pattern :dash-offset 
    73              :line-join    :miter-limit
     71     ;; colors
     72     color?   color=
     73     gray     gray:val
     74     rgb      rgb:r  rgb:g  rgb:b
     75     hsb      hsb:h  hsb:s  hsb:b
     76     cmyk     cmyk:c cmyk:m cmyk:y cmyk:k
    7477
    75              ;; colors
    76              color?   color=
    77              gray     gray:val
    78              rgb      rgb:r  rgb:g  rgb:b
    79              hsb      hsb:h  hsb:s  hsb:b
    80              cmyk     cmyk:c cmyk:m cmyk:y cmyk:k
     78     ;; char map
     79     char-map?
     80     base-char-map
     81     lookup-char-map
     82     function->char-map
     83     alist->char-map
     84     mask-char-map
     85     native-font-char-map
    8186
    82              ;; char map
    83              char-map?
    84              base-char-map
    85              lookup-char-map
    86              function->char-map
    87              alist->char-map
    88              mask-char-map
    89              native-font-char-map
     87     ;; int map
     88     int-map?
     89     base-int-map
     90     lookup-int-map
     91     function->int-map
     92     alist->int-map
     93     mask-int-map
     94     native-font-int-map
    9095
    91              ;; int map
    92              int-map?
    93              base-int-map
    94              lookup-int-map
    95              function->int-map
    96              alist->int-map
    97              mask-int-map
    98              native-font-int-map
     96     ;; object info
     97     start-pt     
     98     end-pt
     99     bounding-box 
     100     bounding-box:max bounding-box:min
    99101
    100              ;; object info
    101              start-pt     
    102              end-pt
    103              bounding-box 
    104              bounding-box:max bounding-box:min
     102     ;; channel
     103     channel?
     104     show
     105     show-w/ps2-text-channel
     106     ps2-text-channel
     107     close-channel
    105108
    106              ;; channel
    107              channel?
    108              show
    109              show-w/ps2-text-channel
    110              ps2-text-channel
    111              close-channel
     109     ;; bitmap
     110     bitmap?
     111     vector->bitmap
     112     hex-string->bitmap
     113     bin-string->bitmap
    112114
    113              ;; bitmap
    114              bitmap?
    115              vector->bitmap
    116              hex-string->bitmap
    117              bin-string->bitmap
     115     ;; options
     116     :format
     117     :creator      :creation-date  :title
     118     :copyright    :for            :routing
     119     :duplex       :duplex-tumble  :collate 
     120     :num-copies   :orientation
     121     :page-label
    118122
    119              ;; options
    120              :format
    121              :creator      :creation-date  :title
    122              :copyright    :for            :routing
    123              :duplex       :duplex-tumble  :collate 
    124              :num-copies   :orientation
    125              :page-label
     123     ;; util
     124     deg->rad rad->deg
     125     inch
     126     )
    126127
    127              ;; util
    128              deg->rad rad->deg
    129              inch
    130              )
     128  (import scheme
     129          (except chicken define-record))
    131130
    132        (define-syntax with-style
    133          (syntax-rules ()
    134            ((with-style style exp ...)
    135             (fps:with-style* style (lambda () exp ...)))))
    136        
    137        (define-syntax with-attrib
    138          (syntax-rules ()
    139            ((with-attrib (attrib ...) exp ...)
    140             (with-style (apply fps:build-style (fps:default-style) (list attrib ...))
    141                         exp ...))))
    142        
    143        (define pi fps:pi) (define 1/4pi fps:1/4pi) (define 1/2pi fps:1/2pi) (define 3/4pi fps:3/4pi)
    144        (define 5/4pi fps:5/4pi) (define 3/2pi fps:3/2pi) (define 7/4pi fps:7/4pi) (define 2pi fps:2pi)
    145        (define origin fps:origin)
    146        (define identity-matrix fps:identity-matrix)
    147        (define afm-directory-list fps:afm-directory-list)
    148 
    149        ;; font
    150        (define font? fps:font?)
    151        (define font fps:font)
    152 
    153        ;; Point and Matrix
    154        (define pt? fps:pt?) (define pt= fps:pt=)
    155        (define pt fps:pt) (define pt:x fps:pt:x) (define pt:y fps:pt:y)
    156        (define add-pts fps:add-pts)  (define negate-pt fps:negate-pt)  (define scale-pt fps:scale-pt)
    157 
    158        (define matrix? fps:matrix?) (define matrix= fps:matrix=)
    159        (define matrix fps:matrix) (define matrix* fps:matrix*)
    160 
    161        ;; Path Makers
    162        (define path? fps:path?)
    163        (define line fps:line)
    164        (define rect fps:rect)
    165        (define arc fps:arc)
    166        (define tangent-arc fps:tangent-arc)
    167        (define curve fps:curve)
    168        (define close-path fps:close-path)
    169        (define stroke-outline-path fps:stroke-outline-path)
    170        (define bitmap->path fps:bitmap->path)
    171        (define bounding-box->rect fps:bounding-box->rect)
    172        (define the-empty-path fps:the-empty-path)
    173 
    174        ;; glyphs construction
    175        (define char->glyphpath fps:char->glyphpath)
    176        (define int->glyphpath fps:int->glyphpath)
    177        (define glyphname->glyphpath fps:glyphname->glyphpath)
    178        (define vector->glyphpath fps:vector->glyphpath)
    179        (define simple-string->glyphpath fps:simple-string->glyphpath)
    180        (define string->glyphpath fps:string->glyphpath)
    181 
    182        ;; Picture Makers
    183        (define picture? fps:picture?)
    184        (define stroke fps:stroke) (define fill fps:fill) (define clip fps:clip) (define colormap fps:colormap) (define bitmap->pict fps:bitmap->pict)
    185        (define paint-glyphpath fps:paint-glyphpath)
    186        (define the-empty-pict fps:the-empty-pict)
    187 
    188        ;; combination
    189        (define compose fps:compose)       (define compose-path fps:compose-path)   (define compose-pict fps:compose-pict)
    190        (define join fps:join)          (define join-path fps:join-path)      (define join-pict fps:join-pict)
    191        (define link fps:link)
    192 
    193        ;; transformation
    194        (define translate fps:translate) (define rotate fps:rotate) (define scale fps:scale)
    195 
    196        ;; style
    197        (define style? fps:style?)
    198        (define vary-default fps:vary-default)
    199        (define build-style fps:build-style)       
    200        (define with-style* fps:with-style*)
    201 
    202        ;; attributes
    203        (define attrib? fps:attrib?)
    204        (define :color fps::color)        (define :line-cap fps::line-cap)     (define :line-width fps::line-width)
    205        (define :dash-pattern fps::dash-pattern) (define :dash-offset fps::dash-offset) 
    206        (define :line-join fps::line-join)    (define :miter-limit fps::miter-limit)
    207 
    208        ;; colors
    209        (define color? fps:color?)   (define color= fps:color=)
    210        (define gray fps:gray)     (define gray:val fps:gray:val)
    211        (define rgb fps:rgb)      (define rgb:r fps:rgb:r)  (define rgb:g fps:rgb:g)  (define rgb:b fps:rgb:b)
    212        (define hsb fps:hsb)      (define hsb:h fps:hsb:h)  (define hsb:s fps:hsb:s)  (define hsb:b fps:hsb:b)
    213        (define cmyk fps:cmyk)     (define cmyk:c fps:cmyk:c) (define cmyk:m fps:cmyk:m) (define cmyk:y fps:cmyk:y) (define cmyk:k fps:cmyk:k)
    214 
    215        ;; char map
    216        (define char-map? fps:char-map?)
    217        (define base-char-map fps:base-char-map)
    218        (define lookup-char-map fps:lookup-char-map)
    219        (define function->char-map fps:function->char-map)
    220        (define alist->char-map fps:alist->char-map)
    221        (define mask-char-map fps:mask-char-map)
    222        (define native-font-char-map fps:native-font-char-map)
    223 
    224        ;; int map
    225        (define int-map? fps:int-map?)
    226        (define base-int-map fps:base-int-map)
    227        (define lookup-int-map fps:lookup-int-map)
    228        (define function->int-map fps:function->int-map)
    229        (define alist->int-map fps:alist->int-map)
    230        (define mask-int-map fps:mask-int-map)
    231        (define native-font-int-map fps:native-font-int-map)
    232 
    233        ;; object info
    234        (define start-pt fps:start-pt)     
    235        (define end-pt fps:end-pt)
    236        (define bounding-box fps:bounding-box) 
    237        (define bounding-box:max fps:bounding-box:max) (define bounding-box:min fps:bounding-box:min)
    238 
    239        ;; channel
    240        (define channel? fps:channel?)
    241        (define show fps:show)
    242        (define show-w/ps2-text-channel fps:show-w/ps2-text-channel)
    243        (define ps2-text-channel fps:ps2-text-channel)
    244        (define close-channel fps:close-channel)
    245 
    246        ;; bitmap
    247        (define bitmap? fps:bitmap?)
    248        (define vector->bitmap fps:vector->bitmap)
    249        (define hex-string->bitmap fps:hex-string->bitmap)
    250        (define bin-string->bitmap fps:bin-string->bitmap)
    251 
    252        ;; options
    253        (define :format fps::format)
    254        (define :creator fps::creator)      (define :creation-date fps::creation-date)  (define :title fps::title)
    255        (define :copyright fps::copyright)    (define :for fps::for)            (define :routing fps::routing)
    256        (define :duplex fps::duplex)       (define :duplex-tumble fps::duplex-tumble)  (define :collate fps::collate) 
    257        (define :num-copies fps::num-copies)   (define :orientation fps::orientation)
    258        (define :page-label fps::page-label)
    259 
    260        ;; util
    261        (define deg->rad fps:deg->rad) (define rad->deg fps:rad->deg)
    262        (define inch fps:inch)
    263        ) )
    264 
    265  (hygienic-macros
     131  (define-syntax :optional
     132    (syntax-rules ()
     133      ((_ . more) (optional . more))))
    266134
    267135  (define-syntax with-style
    268136    (syntax-rules ()
    269137      ((with-style style exp ...)
    270        (fps:with-style* style (lambda () exp ...)))))
     138       (with-style* style (lambda () exp ...)))))
    271139 
    272140  (define-syntax with-attrib
    273141    (syntax-rules ()
    274142      ((with-attrib (attrib ...) exp ...)
    275        (with-style (apply fps:build-style (fps:default-style) (list attrib ...))
     143       (with-style (apply build-style (default-style) (list attrib ...))
    276144                   exp ...))))
     145
     146  (require-library extras)
     147  (import (except extras format))
     148  (use srfi-1) ;; for filter
     149  (use srfi-69) ;; for hash-table
     150  (use regex)   ;; for string-split-fields
     151
     152  (use records utils format)
     153
     154  (define (field-splitter rx)
     155    (lambda (str #!optional (start 0))
     156      (string-split-fields rx str #t start) ) )
     157
     158  (define (infix-splitter rx)
     159    (lambda (str #!optional (start 0))
     160      (string-split-fields rx str #:infix start) ) )
     161
     162  (define (suffix-splitter rx)
     163    (lambda (str #!optional (start 0))
     164      (string-split-fields rx str #:suffix start) ) )
     165
     166  (define char->ascii char->integer)
     167  (define ascii->char integer->char)
     168
     169  (define (make-string-table) (make-hash-table string=?))
     170  (define table-ref (cut hash-table-ref/default <> <> #f))
     171  (define table-set! hash-table-set!)
     172
     173  (include "conditionals")
     174  (include "defrec")
     175  (include "fps.type")
     176  (include "fps.color")
     177  (include "fps.util")
     178  (include "fps-global")
     179  (include "fps.glyph")
     180  (include "fps.comp")
     181  (include "fps.paint")
     182  (include "fps.map")
     183  (include "fps.afm")
     184  (include "fps.ask")
     185  (include "fps.show")
     186  (include "fps.mat")
     187  (include "fps.style")
     188  (include "fps.bitmap")
     189  (include "fps.options")
     190  (include "ps.path")
     191  (include "ps.misc")
     192
     193  (define-record-printer (pt p port)
     194    (format port "#<pt ~s/~s>" (pt:x p) (pt:y p)))
     195
    277196  )
    278 
    279  (else
    280 
    281   (define-macro (with-style style . exp)
    282     `(fps:with-style* ,style (lambda () ,@exp)))
    283 
    284   (define-macro (with-attrib attribs . exp)
    285     `(with-style (apply fps:build-style (fps:default-style) (list ,@attribs))
    286                  ,@exp) ) )
    287  
    288  )
  • release/4/fps/trunk/fps.setup

    r9929 r12854  
    11(print "compiling fps - this takes a while...")
    2 (compile -s -O2 -d1 fps-base.scm -check-imports -emit-exports fps.exports)
     2(compile -s -O2 -d1 fps.scm -j fps)
     3(compile -s -O2 -d0 fps.import.scm)
     4(compile -c -O2 -d1 fps.scm)
    35
    4 (remove-file* (make-pathname (repository-path) "AFM"))
     6(handle-exceptions ex #f
     7  (remove-directory (make-pathname (repository-path) "AFM")))
    58
    69(install-extension
    710 'fps
    8  '("fps-base.so" "fps.scm" "AFM" "fps-ref.txt" "fps-tutorial.txt" "fps.html")
    9  '((version "1.1.1")
     11 '("fps.so" "fps.import.so" "AFM" "fps-ref.txt" "fps-tutorial.txt"
     12   "fps.o")
     13 '((version "1.1.2")
    1014   (documentation "fps.html")
    11    (examples "fps-examples.scm")
    12    (syntax)
    13    (require-at-runtime fps-base) ) )
     15   (static "fps.o")))
  • release/4/fps/trunk/tests/run.scm

    r12853 r12854  
    1 (use syntax-case fps)
    2 
    3 (import fps)
     1(use fps)
    42
    53;;; Functional PostScript
     
    4846
    4947(define (fractal-arrow height depth)
    50   (let* ((s 3/5)
     48  (let* ((s (/ 3 5))
    5149         (half-width (/ s        ; Width of unit arrow / 2.
    5250                        (- 1 (* s s))))
    5351         (arrow1 (unit-arrow-path depth)))
    54     (stroke (translate (+ (/ (- (inch 8) height) 2) (* 1/2 height))
     52    (stroke (translate (+ (/ (- (inch 8) height) 2) (* (/ 1 2) height))
    5553                       (/ (- (inch 10) height) 2)
    5654                       (scale height height arrow1))
     
    6866         (cw  (deg->rad -135))             ; Clockwise rot angle
    6967         (ccw (- cw))                      ; Counter clockwise rot angle
    70          (s 3/5))                          ; Scale factor
     68         (s (/ 3 5)))                      ; Scale factor
    7169    (let recur ((depth depth))
    7270      (if (<= depth 1) stem
     
    226224  (with-attrib ((:line-width 0.01) (:color (rgb 1 1 1)))
    227225     (let* ((square (stroke (rect (pt 0 0) 1 1)))
    228             (circle (stroke (arc  (pt 1/2 1/2) 1/2 0 2pi)))
     226            (circle (stroke (arc  (pt (/ 1 2) (/ 1 2)) (/ 1 2) 0 2pi)))
    229227            (fill-c (rgb 0 0 1))
    230228            (arc-c  (rgb 1 1 0))
    231229            (draw-one     
    232230             (lambda (start end)
    233                (let* ((a   (stroke (arc (pt 1/2 1/2) 1/2 start end)
     231               (let* ((a   (stroke (arc (pt (/ 1 2) (/ 1 2)) (/ 1 2) start end)
    234232                                   (:color arc-c) (:line-width 0.04))))
    235233                 (compose (fill (bounding-box->rect (bounding-box a))
     
    376374
    377375
     376(demo)
Note: See TracChangeset for help on using the changeset viewer.