#!/usr/local/bin/gosh

;;;
;;; gen-color.scm - Generate the sdl.color library from X11 rgb.txt
;;;
;;;  Copyright(C) 2003 by Michael Vess (mvess@michaelvess.com)
;;;
;;;  Permission to use, copy, modify, distribute this software and
;;;  accompanying documentation for any purpose is hereby granted,
;;;  provided that existing copyright notices are retained in all
;;;  copies and that this notice is included verbatim in all
;;;  distributions.
;;;  This software is provided as is, without express or implied
;;;  warranty.  In no circumstances the author(s) shall be liable
;;;  for any damages arising out of the use of this software.
;;;

(use srfi-13) ;; string
(use srfi-14) ;; char-set

(define *header* ";;;
;;; Generated by gen-color.scm
;;; DO NOT MODIFY BY HAND
;;;

(define-module sdl.color
  (use sdl)

  (export-all)
  )

(select-module sdl.color)


;;
;; accessors to pull RGB values from 24-bit color
;;
(define (color-r c) (bit-field c 16 24))
(define (color-g c) (bit-field c 8 16))
(define (color-b c) (bit-field c 0 8))

;;
;; named colors
;;")

(define *footer* "(provide \"sdl/color\")")


(define (rgb->color str)
  (let ((line (string-split (string-trim-both str) char-set:whitespace)))
    (if (> (length line) 3)
        (let ((r (string->number (car line)))
              (g (string->number (cadr line)))
              (b (string->number (caddr line)))
              (name (string-upcase (string-append "COLOR_"
                                                  (string-join (cdddr line)
                                                               "_")))))
          (if (and (number? r)
                   (number? g)
                   (number? b))
              (let ((out (open-output-string)))
                (format out "(define ~A #x~2,'0X~2,'0X~2,'0X)" name r g b)
                (get-output-string out)))))))


(define (main args)
  (let ((rgb-file "/usr/X11R6/lib/X11/rgb.txt"))
    (if (> (length args) 1)
        (set! rgb-file (cadr args)))

    (let ((port-in (open-input-file rgb-file :if-does-not-exist #f))
          (port-out (open-output-file "color.scm" :if-exists :overwrite)))
      (if port-in
          (let ((colors (port-map rgb->color (lambda ()
                                               (read-line port-in)))))
            (close-input-port port-in)
            ;; output the file
            (format port-out "~a\n" *header*)
            (for-each (lambda (str)
                        (if (string? str)
                            (format port-out "~a\n" str)))
                      colors)
            (format port-out "\n~a\n" *footer*))
          (format #t "File: ~a not found\n" rgb-file))
      (close-output-port port-out)))

  ;; return 0 for success
  0)