144 lines
4.7 KiB
Bash
Executable File
144 lines
4.7 KiB
Bash
Executable File
#!/bin/sh
|
|
:;exec /usr/local/bin/stk -f "$0" "$@"
|
|
;;;;
|
|
;;;; A simple color picker in Tk.
|
|
;;;;
|
|
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its 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 any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Last file update: 3-Sep-1999 19:26 (eg)
|
|
;;;;
|
|
;;;;
|
|
;;;; Clicking button 1 on the color box sets the text color
|
|
;;;; to that color; Clicking button 3 sets the background.
|
|
;;;; We read /usr/X11R6/lib/X11/rgb.txt by default. Change the
|
|
;;;; file here if it is somewhere else on your system; if it
|
|
;;;; is a different file, it must have the same format, e.g.
|
|
;;;; rrr ggg bbb color name
|
|
;;;;
|
|
;;;; This demo is inspired from a Tcl program found on the News.
|
|
;;;; Original author is <schmi107@maroon.tc.umn.edu>.
|
|
|
|
(require "Tk-classes")
|
|
(define max-page 10)
|
|
|
|
(define color-file "/usr/X11R6/lib/X11/rgb.txt")
|
|
(define colors '())
|
|
(define item-text (make-vector max-page))
|
|
(define item-color (make-vector max-page))
|
|
(define color-count 0)
|
|
(define color-index 0)
|
|
|
|
|
|
;;;; We cannot create all the colors in the canvas immediately because that uses
|
|
;;;; up the colormap. Instead we only display N items and then configure their
|
|
;;;; colors as we do fake scroll.
|
|
|
|
(define (color-adjust s args)
|
|
(case (car args)
|
|
((moveto) (set! color-index (inexact->exact (* (cadr args) color-count))))
|
|
((scroll) (case (caddr args)
|
|
((pages) (set! color-index (+ color-index
|
|
(* max-page (cadr args)))))
|
|
((units) (set! color-index (+ color-index (cadr args)))))))
|
|
(if (< color-index 0)
|
|
(set! color-index 0))
|
|
(if (> (+ color-index max-page) color-count)
|
|
(set! color-index (- color-count max-page)))
|
|
|
|
(dotimes (i max-page)
|
|
(let ((col (vector-ref colors (+ color-index i))))
|
|
(set! (fill (vector-ref item-color i)) col)
|
|
(set! (text-of (vector-ref item-text i)) col)))
|
|
(update-scrollbar s))
|
|
|
|
|
|
(define (update-scrollbar s)
|
|
(scrollbar-set! s (/ color-index color-count)
|
|
(/ (+ color-index max-page) color-count))
|
|
(update 'idletasks))
|
|
|
|
|
|
;;;; Read the color file
|
|
(define (read-database file)
|
|
(with-input-from-file file
|
|
(lambda ()
|
|
(display "Reading RGB file ...") (flush)
|
|
(let ((rgx (string->regexp
|
|
"^[ \t]*[0-9]+[ \t]+[0-9]+[ \t]+[0-9]+[ \t]*(.*)$")))
|
|
(do ((l (read-line) (read-line)))
|
|
((eof-object? l))
|
|
(let ((match (rgx l)))
|
|
(when match
|
|
(set! colors (cons (apply substring l (cadr match)) colors)))))
|
|
(set! colors (list->vector (reverse colors)))
|
|
(set! color-count (vector-length colors)))
|
|
(display " done\n"))))
|
|
|
|
(define (make-chooser parent)
|
|
;; Make the scroll
|
|
(let* ((f (make <Frame> :parent parent))
|
|
(c (make <Canvas> :parent f :width 200 :height 200))
|
|
(s (make <Scrollbar> :parent f :relief "sunken" :width 10)))
|
|
|
|
(pack s :side "left" :fill "y")
|
|
(pack c :expand #t :fill "x")
|
|
(dotimes (i 10)
|
|
(let ((pos (* i 20))
|
|
(col (vector-ref colors i)))
|
|
|
|
(vector-set! item-color i (make <Rectangle>
|
|
:parent c
|
|
:coords (list 0 pos 50 (+ pos 19))
|
|
:fill col
|
|
:outline ""))
|
|
(vector-set! item-text i (make <Text-item>
|
|
:parent c
|
|
:coords (list 55 (+ pos 3))
|
|
:anchor "nw"
|
|
:text col
|
|
:tags "text"))))
|
|
(bind c "<Button-1>" (lambda (y)
|
|
(let ((item (vector-ref item-text (quotient y 20))))
|
|
(set! (background c) (text-of item)))))
|
|
(bind c "<Button-3>" (lambda (y)
|
|
(let ((item (vector-ref item-text (quotient y 20))))
|
|
(item-configure c "text" :fill (text-of item)))))
|
|
;; Set the command associated to the scrollbar
|
|
(set! (command s) (lambda l (color-adjust s l)))
|
|
(update-scrollbar s)
|
|
(pack f :fill "x")
|
|
|
|
(pack (make <Button> :parent parent :text "Select"
|
|
:command (let ((e (make <Entry>)))
|
|
;; Create an entry to set the selection
|
|
;; This is silly but can we do better in Tk?
|
|
(lambda ()
|
|
(let ((s (format #f "-bg ~s -fg ~s"
|
|
(background c)
|
|
(list-ref (item-configure c "text" :fill)
|
|
4))))
|
|
(set! (value e) s)
|
|
(selection-set! e 0 (string-length s))))))
|
|
|
|
(make <Button> :parent parent :text "Quit"
|
|
:command (lambda () (exit 0)))
|
|
:side "left" :fill "both" :expand #t)
|
|
(pack f :expand #t :fill "both")))
|
|
|
|
(wm 'withdraw ".")
|
|
(read-database color-file)
|
|
(make-chooser (make <Toplevel> :title "Tkcolors"))
|
|
|
|
|
|
|