diff --git a/collects/file/scribblings/file.scrbl b/collects/file/scribblings/file.scrbl index 02a4aeb950..17cd6d2e4c 100644 --- a/collects/file/scribblings/file.scrbl +++ b/collects/file/scribblings/file.scrbl @@ -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" diff --git a/collects/file/scribblings/xpm.scrbl b/collects/file/scribblings/xpm.scrbl deleted file mode 100644 index 12f78137be..0000000000 --- a/collects/file/scribblings/xpm.scrbl +++ /dev/null @@ -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?)])] diff --git a/collects/file/xpm.rkt b/collects/file/xpm.rkt deleted file mode 100644 index f6129fa91a..0000000000 --- a/collects/file/xpm.rkt +++ /dev/null @@ -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%))]) \ No newline at end of file diff --git a/collects/meta/props b/collects/meta/props index 4f4b5739b0..ffc4c40f14 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -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" *) diff --git a/collects/tests/file/xpm-show.rkt b/collects/tests/file/xpm-show.rkt deleted file mode 100644 index 0616d27dc1..0000000000 --- a/collects/tests/file/xpm-show.rkt +++ /dev/null @@ -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) \ No newline at end of file diff --git a/collects/tests/file/xpm.rkt b/collects/tests/file/xpm.rkt deleted file mode 100644 index 667685ccb0..0000000000 --- a/collects/tests/file/xpm.rkt +++ /dev/null @@ -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))))