Revert "Adding XPM parser"
Not needed, since an XPM parser was already implemented.
This reverts commit 4d58a10ff4.
This commit is contained in:
Eli Barzilay
parent
28e79e5bcb
commit
0ffe4c1efb
|
|
@ -1,5 +1,5 @@
|
|||
#lang scribble/doc
|
||||
@(require "common.rkt")
|
||||
@(require "common.ss")
|
||||
|
||||
@title{@bold{File}: Racket File Format Libraries}
|
||||
|
||||
|
|
@ -11,7 +11,6 @@
|
|||
@include-section["tar.scrbl"]
|
||||
@include-section["md5.scrbl"]
|
||||
@include-section["gif.scrbl"]
|
||||
@include-section["xpm.scrbl"]
|
||||
|
||||
@(bibliography
|
||||
(bib-entry #:key "Gervautz1990"
|
||||
|
|
|
|||
|
|
@ -1,24 +0,0 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
(for-label racket/gui
|
||||
file/xpm))
|
||||
|
||||
@title[#:tag "xpm"]{XPM File Reading}
|
||||
|
||||
@defmodule[file/xpm]
|
||||
|
||||
The @racketmodname[file/xpm] library provides functions for
|
||||
reading XPM files and converting them to @racket[bitmap%] objects.
|
||||
|
||||
@defproc[(xpm-read) xpm?]{Reads an XPM from the current input port.}
|
||||
|
||||
@defproc[(xpm->bitmap% [xpm xpm?]) (is-a?/c bitmap%)]{Converts an XPM to a @racket[bitmap%].}
|
||||
|
||||
@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?)])]
|
||||
|
|
@ -1,168 +0,0 @@
|
|||
#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%))])
|
||||
|
|
@ -716,7 +716,6 @@ 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" *)
|
||||
|
|
@ -1381,8 +1380,6 @@ 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" *)
|
||||
|
|
|
|||
|
|
@ -1,18 +0,0 @@
|
|||
#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)
|
||||
|
|
@ -1,18 +0,0 @@
|
|||
#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))))
|
||||
Loading…
Reference in New Issue
Block a user