;;;; console-customize.stk -- console customization stuff
;;;;
;;;; Copyright © 1998-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]
;;;; 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 "<<Choose-Color>>")))))))
(pack n v c :side 'left :padx 2)
;; Fill the entry with the name of the current color
(v 'insert 0 col)
(bind c "<Return>" (lambda () (event 'generate v "<<Choose-Color>>")))
(bind v "<<Choose-Color>>" (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 "<Return>" (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")