;;;; console-customize.stk -- console customization stuff ;;;; ;;;; Copyright © 1998-1999 Erick Gallesio - I3S-CNRS/ESSI ;;;; ;;;; 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] ;;;; Creation date: 19-Dec-1998 16:39 ;;;; Last file update: 3-Sep-1999 19:49 (eg) (require "console") (require "edit") ; for *editor-font* (require "font-chooser") (select-module Tk) (define make-font-chooser (with-module STklos+Tk make-font-chooser)) ; kludge (define (make-console-color-button parent name var env) (let* ((col (eval var env)) (f (frame (& parent (gensym ".f")))) (n (label (& f ".n") :text name :justify 'right :width 12 :anchor 'e)) (v (entry (& f ".v") :bg "white" :width 30 :fg col)) (c (button (& f ".c") :image (make-image "colors.gif") :command (lambda () (let ((c (Tk:choose-color :initial-color col :title (string-append name " Color")))) (when c (v 'delete 0 'end) (v 'insert 0 c) (event 'gen v "<>"))))))) (pack n v c :side 'left :padx 2) ;; Fill the entry with the name of the current color (v 'insert 0 col) (bind c "" (lambda () (event 'generate v "<>"))) (bind v "<>" (lambda () (let ((value (v 'get))) (catch (tk-set! v :fg value) (eval `(set! ,var ,value) env))))) f)) (define (make-console-font-button parent name var env) (let* ((font (eval var env)) (f (frame (& parent (gensym ".f")))) (n (label (& f ".n") :text name :justify 'right :width 12 :anchor 'e)) (v (entry (& f ".v") :bg "white" :width 30)) (new (lambda () (let ((f (make-font-chooser font))) (when f (v 'delete 0 'end) (v 'insert 0 f) (eval `(set! ,var ',f) env))))) (c (button (& f ".c") :image (make-image "font.gif") :command new))) (pack n v c :side 'left :padx 2) (bind v "" (lambda () (eval `(set! ,var ',(v 'get)) env))) ;; Fill the entry with the name of the current color (v 'insert 0 font) f)) (define (console-save-n-apply file) ;; Write variables in the given file (with-output-to-file file (lambda () (format #t "; This file isautomatically generated\n; ****DO NOT EDIT ***\n") (format #t "(select-module STk)\n") (format #t "(set! *show-splash-screen* ~A)\n" *show-splash-screen*) (format #t "(set! *print-banner* ~A)\n" *print-banner*) (format #t "(set! *load-verbose* ~A)\n" *load-verbose*) (format #t "(set! *fontify-keyword-color* ~S)\n" *fontify-keyword-color*) (format #t "(set! *fontify-class-color* ~S)\n" *fontify-class-color*) (format #t "(set! *fontify-syntax-color* ~S)\n" *fontify-syntax-color*) (format #t "(set! *fontify-comment-color* ~S)\n" *fontify-comment-color*) (format #t "(set! *fontify-string-color* ~S)\n" *fontify-string-color*) (format #t "(set! *console-font* '~S)\n" *console-font*) ;; Use a define for *editor-font* since the editor is possibly not loaded (format #t "(define *editor-font* '~S)\n" *editor-font*)))) ;============================================================================= ; ; console-customize-save ; ;============================================================================= (define (console-customize-save) (console-save-n-apply (expand-file-name "~/.stkvars"))) ;============================================================================= ; ; console-customize ; ;============================================================================= (define (console-customize) (destroy ".__cons_customize") (let* ((top (toplevel ".__cons_customize")) (env (global-environment)) (f1 (frame (& top ".f1") :bd 3 :relief "groove" :bg "white")) (f2 (frame (& top ".f2") :bd 3 :relief "groove")) (f3 (frame (& top ".f3") :bd 3 :relief "groove")) (lab (label (& f1 ".lab") :text (string-append "This is the customization window for STk.\n\n" "Change the following values to customize\n" "the behavior of consoles and editors.") :bg "white" :justify 'left)) (logo (label (& f1 ".lab2") :bd 0 :relief "flat" :image (make-image "STk-logo.gif"))) (clab (label (& f2 ".clab") :text "General Options" :fg "IndianRed3")) (splash (checkbutton (& f2 ".splash") :text "Display the splash screen" :env env :variable '*show-splash-screen* :anchor 'w)) (cprwt (checkbutton (& f2 ".cprwt") :text "Display the STk version when starting" :env env :variable '*print-banner* :anchor 'w)) (verb (checkbutton (& f2 ".verb") :text "Load verbose" :env env :variable '*load-verbose* :anchor 'w)) (hlab (label (& f2 ".hlab") :text "Syntax Hilighting" :fg "IndianRed3")) (flab (label (& f2 ".flab") :text "Fonts" :fg "IndianRed3"))) ;; Change window title (wm 'title top "STk Customization Window") ;; *** The upper frame *** (pack logo lab :side 'left :fill 'x :pady '3m :padx '3m) (pack f1 :side 'top :fill 'x :padx 5 :pady 5) ;; *** The lower-frame *** ; G e n e r a l O p t i o n s (pack clab :side 'top :fill 'x) (pack splash cprwt verb :side 'top :fill 'x :padx '3m) ; S y n t a x h i g h l i g h t i n g (pack hlab :side 'top :fill 'x) (pack (make-console-color-button f2 "Comments" '*fontify-comment-color* env) (make-console-color-button f2 "Keywords" '*fontify-keyword-color* env) (make-console-color-button f2 "Classes" '*fontify-class-color* env) (make-console-color-button f2 "Strings" '*fontify-string-color* env) (make-console-color-button f2 "Syntax" '*fontify-syntax-color* env) :side 'top :fill 'x :padx '3m) ; F o n t s (pack flab :side 'top :fill 'x) (pack (make-console-font-button f2 "Console" '*console-font* env) (make-console-font-button f2 "Editor" '*editor-font* env) :side 'top :fill 'x :padx '3m) (pack f2 :side 'top :fill 'x :padx 5 :pady 5) ;; *** The buttons *** (let ((b1 (button (& f3 ".save") :text "Save" :bd 2 :command console-customize-save)) (b2 (button (& f3 ".exit") :text "Cancel" :bd 2 :command (lambda () (destroy top))))) (pack b1 b2 :side 'left :padx 3 :pady 3 :fill 'y) (pack f3 :fill 'x :side 'bottom)))) (provide "console-customize")