scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

fixed string->color

This commit is contained in:
Johan Ceuppens 2012-01-16 22:36:10 +00:00
parent b87531989a
commit e62303f795
1 changed files with 17 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
scsh/scgame/scgamedictionaries.scm
View File

@ -1,4 +1,4 @@
;;; scgamedictionaries.scm - a scheme dictionary system for scgame ;;; scgamedictionaries.scm - a scheme dictionary system for scgame
;;; ;;;
;;; Copyright (c) 2011-2012 Johan Ceuppens ;;; Copyright (c) 2011-2012 Johan Ceuppens
;;; ;;;
@ -28,7 +28,7 @@
;; Dictionary ADT with ref,set!,add!,make public methods at the end ;; Dictionary ADT with ref,set!,add!,make public methods at the end
(define (make-dictionary1) (define (make-dictionary1)
;; methods are FIFO (first fixed first out) ;; methods are FIFO (first fixed first out)
(let ((*dict '())) (let ((*dict '()))
(define (get key) ;; get key (define (get key) ;; get key
@ -47,10 +47,10 @@
(set! *dict (append res (cdr l)))) (set! *dict (append res (cdr l))))
)) ))
(lambda (msg) (lambda (msg)
(cond ((eq? msg 'get) get) (cond ((eq? msg 'get) get)
((eq? msg 'set) set) ((eq? msg 'set) set)
((eq? msg 'add) add) ((eq? msg 'add) add)
(else (aspecterror)(display "make-dictionary")))) (else (aspecterror)(display "make-dictionary"))))
)) ))
@ -65,10 +65,10 @@
(define (string->color str) (define (string->color str)
(let ((colornumber 0)) (let ((colornumber 0))
(do ((i 0 (+ i 1))) (do ((i (- (string-length str) 1) (- i 1)))
((< i (string-length str)) colornumber) ((< i 0) colornumber)
(let* ((c (string-ref str i)) (let ((c (string-ref str i)))
(n (cond ((or (eq? c #\a)(eq? c #\A)) (let ((n (cond ((or (eq? c #\a)(eq? c #\A))
10) 10)
((or (eq? c #\b)(eq? c #\B)) ((or (eq? c #\b)(eq? c #\B))
11) 11)
@ -81,7 +81,7 @@
((or (eq? c #\f)(eq? c #\F)) ((or (eq? c #\f)(eq? c #\F))
15) 15)
(else (string->number (string c)))))) (else (string->number (string c))))))
(set! colornumber (+ (* n 16) colornumber)))))) (set! colornumber (+ (* (+ n 1) 16 i) colornumber)))))))
(define (little-endian->big-endian n) (define (little-endian->big-endian n)
(let ((str (string n)) (let ((str (string n))
@ -89,8 +89,8 @@
(do ((i (string-length str) (- i 1))) (do ((i (string-length str) (- i 1)))
((<= i 0) ((<= i 0)
(string->number rets)) (string->number rets))
(set! rets (string (set! rets (string
(bitwise-and (bitwise-and
(string->number (* (expt 2 i)(string-ref str i))) (string->number (* (expt 2 i)(string-ref str i)))
(string->number rets))))) (string->number rets)))))
)) ))
@ -101,8 +101,8 @@
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((>= i (string-length str)) ((>= i (string-length str))
(string->number rets)) (string->number rets))
(set! rets (string (set! rets (string
(bitwise-and (bitwise-and
(string->number (* (expt 2 i)(string-ref str i))) (string->number (* (expt 2 i)(string-ref str i)))
(string->number rets))))) (string->number rets)))))
)) ))
@ -111,9 +111,9 @@
(define (make-color-dictionary bpp) (define (make-color-dictionary bpp)
(let ((dict (make-dictionary)) (let ((dict (make-dictionary))
(pow (expt 2 bpp))) (pow (expt 2 bpp)))
(cond ((= pow 16) ;; 16 colors (cond ((= pow 16) ;; 16 colors
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
((< i pow) ((< i pow)
(dictionary-add! dict i i))) (dictionary-add! dict i i)))
(dictionary-add! dict 'black 0) (dictionary-add! dict 'black 0)
@ -123,7 +123,7 @@
(dictionary-add! dict 'black 0) (dictionary-add! dict 'black 0)
;; ... FIXME fill in 8-bit colors ;; ... FIXME fill in 8-bit colors
dict) dict)
(else (display "color-dictionary : no or unsupported bit depth. Using CSS dictionary") (else (display "color-dictionary : no or unsupported bit depth. Using CSS dictionary")
(dictionary-add! dict 'Black "000000") (dictionary-add! dict 'Black "000000")
(dictionary-add! dict 'Navy "000080") (dictionary-add! dict 'Navy "000080")
(dictionary-add! dict 'DarkBlue "00008B") (dictionary-add! dict 'DarkBlue "00008B")
@ -272,5 +272,5 @@
(dictionary-add! dict 'Ivory "FFFFF0") (dictionary-add! dict 'Ivory "FFFFF0")
(dictionary-add! dict 'White "FFFFFF") (dictionary-add! dict 'White "FFFFFF")
)) ))
)) ))