Revert "Adding XPM parser"

Not needed, since an XPM parser was already implemented.

This reverts commit 4d58a10ff4.

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"

collects/file/scribblings/xpm.scrbl

@@ -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?)])]

collects/file/xpm.rkt

@@ -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%))])

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" *)

collects/tests/file/xpm-show.rkt

@@ -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)

collects/tests/file/xpm.rkt

@@ -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))))