[Chicken-users] Set! question - long example

[William Ramsay]

Graham,

This is a long example, but it's my actual code that now does exactly 
what I want.    It's a typical dialog box for choosing preferences in a 
in a text editor.   The colors-set box has a label explaining what it 
is, a Gtk color button, and another label showing a string in the colors 
chosen.    Because of the background, the colors inter-relate.   And 
what makes it hard is that the user can try a zillion combinations and 
then cancel the changes and go back to the beginning.

Please forgive my code it it seems bloated.   The first priority in 
programming is always to get it to work first.

(define cb1 #f)
(define cb2 #f)
(define cb3 #f)
(define cb4 #f)
(define cb5 #f)
(define cb6 #f)
(define cb7 #f)
(define cb8 #f)
(define cb9 #f)
(define cb10 #f)
(define cb11 #f)
(define cb12 #f)

(define backup (make-vector 19))
 
(define show-prefs-dialog
 (lambda ()
   (let
     ((dialog (gtk_dialog_new))
      (vbox #f)
      (hbox (gtk_hbox_new #f 2))
      (vbox1 (gtk_vbox_new #f 2))
      (vbox2 (gtk_vbox_new #f 2))
      (res -1)
      (line1 (sutils-get-entry (sutils-get-text "lang") 20 14
             (vector-ref pref-list LANGUAGE-FILE)))
      (line2 (sutils-get-entry (sutils-get-text "proot") 40 14 
project-path))
      (line3 (sutils-get-entry (sutils-get-text "pfile") 40 14 
project-file))
      (line4 (sutils-get-entry (string-append (sutils-get-text "prefs") 
":")
                                40 14 prefs-file))
      (line5 (sutils-get-entry (sutils-get-text "ptabs") 10 14 
(vector-ref pref-list TABS)))
      (fontbox   (gtk_fixed_new))
      (fontlab   (gtk_label_new (sutils-get-text "pfont")))
      (fontbut (gtk_font_button_new_with_font (vector-ref pref-list FONT)))
      (indentbox (gtk_fixed_new))
      (indentbut (gtk_check_button_new_with_label (sutils-get-text 
"paind"))))
    
     (vector-copy! pref-list backup)
     (set! cb1 (create-color-set "ebg" (vector-ref backup C_BACKGROUND)
                                       (vector-ref backup C_BACKGROUND)
                                       (vector-ref backup C_FOREGROUND)))
     (set! cb2 (create-color-set "ntxt" (vector-ref backup C_FOREGROUND)
                                        (vector-ref backup C_BACKGROUND)
                                        (vector-ref backup C_FOREGROUND)))
     (set! cb3 (create-color-set "ccol" (vector-ref backup C_COMMENT)
                                        (vector-ref backup C_BACKGROUND)
                                        (vector-ref backup C_COMMENT)))
     (set! cb4 (create-color-set "key1" (vector-ref backup C_KEY1)
                                        (vector-ref backup C_BACKGROUND)
                                        (vector-ref backup C_KEY1)))
     (set! cb5 (create-color-set "key2" (vector-ref backup C_KEY2)
                                        (vector-ref backup C_BACKGROUND)
                                        (vector-ref backup C_KEY2)))
     (set! cb6 (create-color-set "key3" (vector-ref backup C_KEY3)
                                        (vector-ref backup C_BACKGROUND)
                                        (vector-ref backup C_KEY3)))
     (set! cb7 (create-color-set "str" (vector-ref backup C_STRING)
                                       (vector-ref backup C_BACKGROUND)
                                       (vector-ref backup C_STRING)))
     (set! cb8 (create-color-set "num" (vector-ref backup C_NUMBER)
                                       (vector-ref backup C_BACKGROUND)
                                       (vector-ref backup C_NUMBER)))
     (set! cb9 (create-color-set "func" (vector-ref backup C_METHOD)
                                        (vector-ref backup C_BACKGROUND)
                                        (vector-ref backup C_METHOD)))
     (set! cb10 (create-color-set "ops" (vector-ref backup C_OPERATOR)
                                        (vector-ref backup C_BACKGROUND)
                                        (vector-ref backup C_OPERATOR)))
     (set! cb11 (create-color-set "regex" (vector-ref backup C_REGEX)
                                          (vector-ref backup C_BACKGROUND)
                                          (vector-ref backup C_REGEX)))
     (set! cb12 (create-color-set "parens" (vector-ref backup C_PARENS)
                                           (vector-ref backup C_BACKGROUND)
                                           (vector-ref backup C_PARENS)))
     
     (gtk_window_set_title dialog (sutils-get-text "prefs"))
     (set! vbox (get_dialog_work_area dialog))
    
     (gtk_box_pack_start vbox1 (car line1) #f #f 5)
     (gtk_box_pack_start vbox1 (car line2) #f #f 5)
     (gtk_box_pack_start vbox1 (car line3) #f #f 5)
     (gtk_box_pack_start vbox1 (car line4) #f #f 5)
     (gtk_box_pack_start vbox1 (car line5) #f #f 5)

     (gtk_widget_set_size_request fontbox 300 28)
     (gtk_label_set_max_width_chars fontlab 14)   
     (gtk_fixed_put fontbox fontlab 5 10)
     (gtk_fixed_put fontbox fontbut 100 5)
     (gtk_box_pack_start vbox1 fontbox #f #f 5)
    
     (gtk_toggle_button_set_active indentbut (vector-ref backup 
AUTO-INDENT))
     (gtk_fixed_put indentbox indentbut 100 5)
     (gtk_box_pack_start vbox1 indentbox #f #f 5)
    
     (gtk_box_pack_start vbox2 (car cb1) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb2) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb3) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb4) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb5) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb6) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb7) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb8) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb9) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb10) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb11) #f #f 5)
     (gtk_box_pack_start vbox2 (car cb12) #f #f 5)
    
     (gtk_box_pack_start hbox vbox1 #f #f 5)
     (gtk_box_pack_start hbox vbox2 #f #f 5)
     (gtk_box_pack_start vbox hbox #f #f 5)
    
     (gtk_dialog_add_button dialog (sutils-get-text "fsave") R_SAVE)     
     (gtk_dialog_add_button dialog (sutils-get-text "dlcancel") R_CANCEL)

     (gtk_widget_show (car line1))
     (gtk_widget_show (car line2))
     (gtk_widget_show (car line3))
     (gtk_widget_show (car line4))
     (gtk_widget_show (car line5))
     (gtk_widget_show (car cb1))
     (gtk_widget_show (car cb2))
     (gtk_widget_show (car cb3))
     (gtk_widget_show (car cb4))
     (gtk_widget_show (car cb5))
     (gtk_widget_show (car cb6))
     (gtk_widget_show (car cb7))
     (gtk_widget_show (car cb8))
     (gtk_widget_show (car cb9))
     (gtk_widget_show (car cb10))
     (gtk_widget_show (car cb11))
     (gtk_widget_show (car cb12))

     (gtk_widget_show fontlab)
     (gtk_widget_show fontbut)
     (gtk_widget_show fontbox)
     (gtk_widget_show indentbut)
     (gtk_widget_show indentbox)
     (gtk_widget_show vbox1)
     (gtk_widget_show vbox2)
     (gtk_widget_show hbox)
     (gtk_widget_show vbox)
     
     (set! res (gtk_dialog_run dialog))
     (if (= res R_SAVE)
       (save-preferences (gtk_entry_get_text (car (cdr line1)))
                         (gtk_entry_get_text (car (cdr line2)))
                         (gtk_entry_get_text (car (cdr line3)))
                         (gtk_entry_get_text (car (cdr line4)))
                         (gtk_entry_get_text (car (cdr line5)))
                         (gtk_font_button_get_font_name fontbut)
                         (gtk_toggle_button_get_mode indentbut)))
                                                     
     (gtk_widget_destroy dialog))))


(define set-color
 (lambda (widget)
   (let
     ((color (get_button_color widget))
      (hexcolor #f))     
    
     (set! hexcolor (sutils-get-hex-string (get_color_red color)
                        (get_color_green color) (get_color_blue color)))
                                  
     (cond
       ((equal? widget (car (cdr cb1))) (set-all-backgrounds hexcolor)
                                        (vector-set! backup 
C_BACKGROUND hexcolor))
       ((equal? widget (car (cdr cb2))) (set-foreground (car (list-tail 
cb2 2)) hexcolor)
                                        (vector-set! backup 
C_FOREGROUND hexcolor))
       ((equal? widget (car (cdr cb3))) (set-foreground (car (list-tail 
cb3 2)) hexcolor)
                                        (vector-set! backup C_COMMENT 
hexcolor))
       ((equal? widget (car (cdr cb4))) (set-foreground (car (list-tail 
cb4 2)) hexcolor)
                                        (vector-set! backup C_KEY1 
hexcolor))
       ((equal? widget (car (cdr cb5))) (set-foreground (car (list-tail 
cb5 2)) hexcolor)
                                        (vector-set! backup C_KEY2 
hexcolor))
       ((equal? widget (car (cdr cb6))) (set-foreground (car (list-tail 
cb6 2)) hexcolor)
                                        (vector-set! backup C_KEY3 
hexcolor))
       ((equal? widget (car (cdr cb7))) (set-foreground (car (list-tail 
cb7 2)) hexcolor)
                                        (vector-set! backup C_STRING 
hexcolor))
       ((equal? widget (car (cdr cb8))) (set-foreground (car (list-tail 
cb8 2)) hexcolor)
                                        (vector-set! backup C_NUMBER 
hexcolor))
       ((equal? widget (car (cdr cb9))) (set-foreground (car (list-tail 
cb9 2)) hexcolor)
                                        (vector-set! backup C_METHOD 
hexcolor))
       ((equal? widget (car (cdr cb10))) (set-foreground (car 
(list-tail cb10 2)) hexcolor)
                                        (vector-set! backup C_OPERATOR 
hexcolor))
       ((equal? widget (car (cdr cb11))) (set-foreground (car 
(list-tail cb11 2)) hexcolor)
                                        (vector-set! backup C_REGEX 
hexcolor))
       ((equal? widget (car (cdr cb12))) (set-foreground (car 
(list-tail cb12 2)) hexcolor)
                                        (vector-set! backup C_PARENS 
hexcolor))))))
    

(define set-foreground
 (lambda (example fg)
   (let
     ((markup (g_markup_printf_escaped
               "<span foreground=\"%s\" background=\"%s\" 
weight=\"bold\"> %s </span>"
                fg (vector-ref backup C_BACKGROUND) (sutils-get-text 
"ctext"))))
     
     (gtk_label_set_markup example markup))))



(define set-background
 (lambda (item bg fg)
   (let
     ((markup (g_markup_printf_escaped
               "<span foreground=\"%s\" background=\"%s\" 
weight=\"bold\"> %s </span>"
                fg bg (sutils-get-text "ctext"))))
    
     (gtk_label_set_markup item markup))))
            

(define set-all-backgrounds
 (lambda (bg)
   (vector-set! backup C_BACKGROUND bg)
   (set-background (car (list-tail cb1 2)) bg (vector-ref backup 
C_FOREGROUND))
   (set-background (car (list-tail cb2 2)) bg (vector-ref backup 
C_FOREGROUND))
   (set-background (car (list-tail cb3 2)) bg (vector-ref backup 
C_COMMENT))
   (set-background (car (list-tail cb4 2)) bg (vector-ref backup C_KEY1))
   (set-background (car (list-tail cb5 2)) bg (vector-ref backup C_KEY2))
   (set-background (car (list-tail cb6 2)) bg (vector-ref backup C_KEY3))
   (set-background (car (list-tail cb7 2)) bg (vector-ref backup C_STRING))
   (set-background (car (list-tail cb8 2)) bg (vector-ref backup C_NUMBER))
   (set-background (car (list-tail cb9 2)) bg (vector-ref backup C_METHOD))
   (set-background (car (list-tail cb10 2)) bg (vector-ref backup 
C_OPERATOR))
   (set-background (car (list-tail cb11 2)) bg (vector-ref backup C_REGEX))
   (set-background (car (list-tail cb12 2)) bg (vector-ref backup 
C_PARENS))))


Bill