[racket-dev] [plt] Push #20548: master branch updated

Matthew,

You mentioned needing an XPM parser for gr2. I think this should do,
although the initial bitmap background might be wrong. And it might be
more efficient to create the bitmap from bytes rather than with the
dc.

Jay

On Tue, Jun 22, 2010 at 11:33 AM,  <jay at racket-lang.org> wrote:
> jay has updated `master' from bce2cedf38 to 4d58a10ff4.
>  http://git.racket-lang.org/plt/bce2cedf38..4d58a10ff4
>
> =====[ 1 Commits ]======================================================
>
> 4d58a10 Jay McCarthy <jay at racket-lang.org> 2010-06-22 11:32
> :
> | Adding XPM parser
> :
>  M collects/file/scribblings/file.scrbl |    3 ++-
>  A collects/file/scribblings/xpm.scrbl
>  A collects/file/xpm.rkt
>  M collects/meta/props                  |    3 +++
>  A collects/tests/file/xpm.rkt
>  A collects/tests/file/xpm-show.rkt
>
> =====[ Overall Diff ]===================================================
>
> collects/file/scribblings/file.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/file/scribblings/file.scrbl
> +++ NEW/collects/file/scribblings/file.scrbl
> @@ -1,5 +1,5 @@
>  #lang scribble/doc
> -@(require "common.ss")
> +@(require "common.rkt")
>
>  @title{@bold{File}: Racket File Format Libraries}
>
> @@ -11,6 +11,7 @@
>  @include-section["tar.scrbl"]
>  @include-section["md5.scrbl"]
>  @include-section["gif.scrbl"]
> + at include-section["xpm.scrbl"]
>
>  @(bibliography
>   (bib-entry #:key "Gervautz1990"
>
> collects/file/scribblings/xpm.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/file/scribblings/xpm.scrbl
> @@ -0,0 +1,24 @@
> +#lang scribble/doc
> +@(require scribble/manual
> +          (for-label racket/gui
> +                     file/xpm))
> +
> + at title[#:tag "xpm"]{XPM File Reading}
> +
> + at defmodule[file/xpm]
> +
> +The @racketmodname[file/xpm] library provides functions for
> +reading XPM files and converting them to @racket[bitmap%] objects.
> +
> + at defproc[(xpm-read) xpm?]{Reads an XPM from the current input port.}
> +
> + at defproc[(xpm->bitmap% [xpm xpm?]) (is-a?/c bitmap%)]{Converts an XPM to a @racket[bitmap%].}
> +
> + at defstruct*[xpm ([var string?]
> +                 [width exact-integer?]
> +                 [height exact-integer?]
> +                 [color-ht (hash/c symbol? (hash/c symbol? string?))]
> +                 [x-hotspot (or/c false/c exact-integer?)]
> +                 [y-hotspot (or/c false/c exact-integer?)]
> +                 [pixels (listof (listof symbol?))]
> +                 [extensions (listof string?)])]
>
> collects/file/xpm.rkt
> ~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/file/xpm.rkt
> @@ -0,0 +1,168 @@
> +#lang racket/gui
> +(require parser-tools/yacc
> +         parser-tools/lex
> +         (prefix-in : parser-tools/lex-sre))
> +
> +;;; Parser
> +(define-tokens regular (VARIABLE STRING))
> +(define-empty-tokens keywords (STATIC CHAR STAR BRACKET EQUALS LBRACE RBRACE SEMICOLON COMMA EOF))
> +
> +(define lex-xpm
> +  (lexer
> +   [(eof) (token-EOF)]
> +   ["static" (token-STATIC)]
> +   ["char" (token-CHAR)]
> +   ["*" (token-STAR)]
> +   ["[]" (token-BRACKET)]
> +   ["=" (token-EQUALS)]
> +   ["{" (token-LBRACE)]
> +   ["}" (token-RBRACE)]
> +   [";" (token-SEMICOLON)]
> +   ["," (token-COMMA)]
> +   [whitespace (lex-xpm input-port)]
> +   [(:: "/*" (complement (:: any-string "*/" any-string)) "*/") (lex-xpm input-port)]
> +   [(:: #\" (:* (:or (:~ #\") "\\\"")) #\")
> +    (token-STRING (substring lexeme 1 (- (string-length lexeme) 1)))]
> +   [(:+ (:or (char-range #\a #\z)
> +             (char-range #\A #\Z)
> +             (char-range #\0 #\9)
> +             #\_
> +             #\- ; Not really allowed but mini-plt uses it
> +             ))
> +    (token-VARIABLE lexeme)]))
> +
> +(define parse-raw-xpm
> +  (parser (start xpm)
> +          (tokens regular keywords)
> +          (grammar (xpm [(STATIC CHAR STAR VARIABLE BRACKET EQUALS LBRACE
> +                                 strings
> +                                 RBRACE)
> +                         (cons $4 $8)])
> +                   (strings [(STRING) (list $1)]
> +                            [(STRING COMMA strings) (list* $1 $3)]))
> +          (end SEMICOLON)
> +          (error (lambda (tok-ok? tok-name tok-value)
> +                   (error
> +                    'parse-raw-xpm
> +                    (format
> +                     (if tok-ok?
> +                         "Did not expect token ~a"
> +                         "Invalid token ~a")
> +                     tok-name))))))
> +
> +;;; Struct
> +
> +(struct xpm (var width height color-ht x-hotspot y-hotspot pixels extensions) #:transparent)
> +
> +;;; Reading
> +
> +(define (xpm-read)
> +  (match-define (cons var strings)
> +                (parse-raw-xpm (位 () (lex-xpm (current-input-port)))))
> +  (define-values (width height ncolors cpp x-hotspot y-hotspot extensions?)
> +    (parse-values (first strings)))
> +  (define-values (colors-strs pixels*ext-strs)
> +    (split-at (rest strings) ncolors))
> +  (define-values (pixels-strs ext-strs)
> +    (split-at pixels*ext-strs height))
> +  (xpm var width height
> +       (parse-colors-ht cpp colors-strs)
> +       x-hotspot y-hotspot
> +       (parse-pixels cpp pixels-strs)
> +       ext-strs))
> +
> +(define parse-values
> +  (match-lambda
> +    [(regexp #px"^\\s*(\\d+)\\s+(\\d+)\\s+(\\d+)\\s+(\\d+)$"
> +             (list _
> +                   (app string->number w)
> +                   (app string->number h)
> +                   (app string->number ncolors)
> +                   (app string->number cpp)))
> +     (values w h ncolors cpp #f #f #f)]))
> +
> +(define (in-list* n l)
> +  (make-do-sequence
> +   (位 ()
> +     (values (位 (l)
> +               (define-values (ret rest) (split-at l n))
> +               (apply values ret))
> +              (位 (l)
> +               (define-values (ret rest) (split-at l n))
> +               rest)
> +              l
> +              (位 (l)
> +                (not (empty? l)))
> +              (位 _ #t)
> +              (位 _ #t)))))
> +
> +(define (split-string-at s n)
> +  (values (substring s 0 n)
> +          (substring s n)))
> +
> +(define (parse-colors-ht cpp ss)
> +  (for/hasheq ([s (in-list ss)])
> +    (define-values (chars rest*) (split-string-at s cpp))
> +    (define rest (regexp-replace #px"^\\s+" rest* ""))
> +    (define ps (regexp-split #px"\\s+" rest))
> +    (values (string->symbol chars)
> +            (for/hasheq ([(context color) (in-list* 2 ps)])
> +              (values (string->symbol context)
> +                      color)))))
> +
> +(define (split-string s n)
> +  (for/list ([i (in-range 0 (/ (string-length s) n))])
> +    (substring s (* i n) (* (add1 i) n))))
> +
> +(define (parse-pixels cpp ss)
> +  (for/list ([row (in-list ss)])
> +    (for/list ([color (in-list (split-string row cpp))])
> +      (string->symbol color))))
> +
> +;;; Displaying
> +
> +(define (hex->number n)
> +  (string->number n 16))
> +
> +(define (color->pen% ht c context)
> +  (define c-ht (hash-ref ht c (位 () (error 'color->pen% "Unknown color ~e" c))))
> +  (define code (hash-ref c-ht context (位 () (error 'color->pen% "Unknown context ~e for color ~e" context c))))
> +  (define style
> +    (match code
> +      ["None" 'transparent]
> +      [_ 'solid]))
> +  (define color
> +    (match code
> +      ["None" "black"]
> +      [(regexp #px"^#([\\da-fA-F]{6})" (list _ hex))
> +       (match-define (list r g b) (split-string hex 2))
> +       (make-object color% (hex->number r) (hex->number g) (hex->number b))]
> +      [_
> +       (error 'color->pen% "Cannot parse ~e" code)]))
> +  (make-object pen% color 1 style))
> +
> +(define xpm->bitmap%
> +  (match-lambda
> +    [(xpm var width height color-ht x-hotspot y-hotspot pixels extensions)
> +     (define the-bitmap (make-object bitmap% width height))
> +     (define the-dc (new bitmap-dc% [bitmap the-bitmap]))
> +     (send the-dc set-background (make-object color% "white"))
> +     (for ([y (in-naturals)]
> +           [row (in-list pixels)])
> +       (for ([x (in-naturals)]
> +             [color (in-list row)])
> +         (send the-dc set-pen (color->pen% color-ht color 'c))
> +         (send the-dc draw-point x y)))
> +     the-bitmap]))
> +
> +(provide/contract
> + [struct xpm ([var string?]
> +              [width exact-integer?]
> +              [height exact-integer?]
> +              [color-ht (hash/c symbol? (hash/c symbol? string?))]
> +              [x-hotspot (or/c false/c exact-integer?)]
> +              [y-hotspot (or/c false/c exact-integer?)]
> +              [pixels (listof (listof symbol?))]
> +              [extensions (listof string?)])]
> + [xpm-read (-> xpm?)]
> + [xpm->bitmap% (xpm? . -> . (is-a?/c bitmap%))])
> \ No newline at end of file
>
> collects/meta/props
> ~~~~~~~~~~~~~~~~~~~
> --- OLD/collects/meta/props
> +++ NEW/collects/meta/props
> @@ -716,6 +716,7 @@ path/s is either such a string or a list of them.
>  "collects/ffi/objc.rkt" responsible (mflatt) drdr:command-line (mzc *)
>  "collects/ffi/unsafe/objc.rkt" responsible (mflatt) drdr:command-line (mzc *)
>  "collects/file" responsible (mflatt)
> +"collects/file/xpm.rkt" responsible (jay) drdr:command-line (gracket "-t" *)
>  "collects/framework" responsible (robby)
>  "collects/framework/collapsed-snipclass.rkt" drdr:command-line (gracket-text "-t" *)
>  "collects/framework/comment-snip.rkt" drdr:command-line (gracket-text "-t" *)
> @@ -1380,6 +1381,8 @@ path/s is either such a string or a list of them.
>  "collects/tests/drracket/syncheck-test.rkt" drdr:command-line (gracket *)
>  "collects/tests/drracket/teachpack.rkt" drdr:command-line (gracket *)
>  "collects/tests/drracket/time-keystrokes.rkt" drdr:command-line (gracket-text "-t" *)
> +"collects/tests/file/xpm-show.rkt" responsible (jay) drdr:command-line #f
> +"collects/tests/file/xpm.rkt" responsible (jay) drdr:command-line (gracket "-t" *)
>  "collects/tests/framework" responsible (robby)
>  "collects/tests/framework/canvas.rkt" drdr:command-line (mzc "-k" *)
>  "collects/tests/framework/debug.rkt" drdr:command-line (mzc "-k" *)
>
> collects/tests/file/xpm-show.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/file/xpm-show.rkt
> @@ -0,0 +1,18 @@
> +#lang racket/gui
> +(require file/xpm)
> +
> +(define the-bitmap
> +  (command-line #:program "xpm-show"
> +                #:args (file)
> +                (xpm->bitmap% (with-input-from-file file xpm-read))))
> +
> +(define frame (new frame% [label "XPM"]))
> +
> +(define canvas
> +  (new canvas%
> +       [parent frame]
> +       [paint-callback
> +        (位 (c dc)
> +          (send dc draw-bitmap the-bitmap 0 0))]))
> +
> +(send frame show #t)
> \ No newline at end of file
>
> collects/tests/file/xpm.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/collects/tests/file/xpm.rkt
> @@ -0,0 +1,18 @@
> +#lang racket
> +(require file/xpm
> +         tests/eli-tester)
> +
> +(define tree-xpms
> +  (for*/list ([collect (in-list (list "icons" "guibuilder"))]
> +              [file (in-directory (collection-path collect))]
> +              #:when (regexp-match #rx"\\.xpm$" (path->bytes file)))
> +    file))
> +
> +(define (xpm-test f)
> +  (test
> +   (xpm->bitmap% (with-input-from-file f xpm-read))))
> +
> +(test
> + (for ([f (in-list tree-xpms)])
> +   (test #:failure-prefix (path->string f)
> +         (xpm-test f))))
>



-- 
Jay McCarthy <jay at cs.byu.edu>
Assistant Professor / Brigham Young University
http://teammccarthy.org/jay

"The glory of God is Intelligence" - D&C 93