;; edit-plug.gwm --- Code for general editable plug
;;
;; Author: Anders Holst  (aho@sans.kth.se)  
;; Copyright (C) 1996  Anders Holst
;; Last change: 19/1 1996
;;
;; This file is copyrighted under the same terms as the rest of GWM
;; (see the X Inc license for details). There is no warranty that it
;; works. 
;;
;; --------------------------------------------------------------------- 
;;
;; This code implements a simple editable plug, which can be used in
;; various places in GWM. Simple examples include dialogues where the
;; user can feed in some text string to GWM (eg. the name of a new
;; virtual door to create or a machine to log into), or editable name
;; plugs in window and icon decorations.
;;
;; To create an editable plug, you just call '(edit-plug-make "string")'
;; where it would otherwise have said '(plug-make (label-make "string"))'.
;; Most communication with the plug is done via user events. To enable
;; editing you send it the event 'edit-plug-start'. To finish or abort
;; editing (that is, go into the passive state) you send 'edit-plug-done'
;; or 'edit-plug-abort' depending on whether the edit should have any
;; effect or not. To find out the new string in an editable plug, you can
;; send the event 'edit-plug-query' and then look at the variable
;; 'edit-plug-result', or you can use the function '(edit-plug-query)'
;; which does exactly this.
;;
;; When the plug is in its active state it obeys several editing keys,
;; including RETURN which finishes editing, and C-c or ESC which aborts
;; editing. (Unfortunately there is no keymap mechanism to allow the
;; user to redefine the meaning of the different keys, other than
;; modifying the fsm:s, see below.)
;;
;; 'edit-plug-make' considers several context variables. In addition to
;; the ones considered by 'plug-make' and 'label-make' it considers
;; 'font-slant' (which if defined determines the slant of the small bar
;; indicating the edit point in the string), 'active-foreground',
;; 'active-background', 'active-borderpixel' (which determines the colors
;; of the plug when in its active state), 'edit-plug-start-hook',
;; 'edit-plug-done-hook', and 'edit-plug-abort-hook' (which contains
;; code to run when starting, finishing, and aborting edit respectively).
;;
;; The fsm is built from the states 'edit-plug-normal-state' and
;; 'edit-plug-active-state'. To specify which events should start and stop
;; the editing, more events can be added to these states.
;; NOTE: Only change these variables in a with-statement and not
;; globally, since edit-plugs might be used in more than one place,
;; and the same behavior might not be appropriate everywhere.
;;
;; As an example of how the edit-plug can be used, there is a function
;; '(simple-dialogue "prompt")' defined, which prompts the user for a
;; string that is then returned. The color and appearance of the simple
;; dialogue box is affected by many of the above mentioned context
;; variables.
;; 


(defun edit-plug-make (str)
  (with (cnx (list 'foreground foreground 'background background
                   'borderpixel borderpixel 'font font
                   'active-foreground (default active-foreground foreground)
                   'active-background (default active-background background)
                   'active-borderpixel (default active-borderpixel ())
                   'font-slant (default font-slant 0)
                   'label-horizontal-margin label-horizontal-margin
                   'label-vertical-margin label-vertical-margin)
         property (+ (list 'internals (list str () ())
                           'context cnx
                           'start-hook (default edit-plug-start-hook ())
                           'done-hook (default edit-plug-done-hook ())
                           'abort-hook (default edit-plug-abort-hook ()))
                     property)
         fsm (fsm-make edit-plug-normal-state edit-plug-active-state))
    (plug-make (edit-plug-label str ()))))

(defun edit-plug-label (str1 str2)
  (with (str (if (and (= str1 "") (or (not str2) (= str2 "")))
                 " "
                 (+ str1 str2))
         xoff (if (not str2)
                  ()
                (= str1 "")
                  (- label-horizontal-margin 1)
                  (- (# 2 (dimensions str1)) label-horizontal-margin 1))
         lab ())
    (setq lab (label-make str))
    (if xoff
        (draw-line lab
                   (+ xoff (- font-slant (/ font-slant 2)))
                   label-vertical-margin
                   (- xoff (/ font-slant 2))
                   (- (# 3 (dimensions " ")) label-vertical-margin 1)))
    lab))

(defun edit-plug-update ()
  (with (ilist (# 'internals wob-property)
         cnx (# 'context wob-property))
    (with cnx
      (if (# 1 ilist) 
          (progn
            (setq background active-background)
            (setq foreground active-foreground)
            (if active-borderpixel
                (setq borderpixel active-borderpixel))))
      (wob-tile (edit-plug-label (# 0 ilist) (# 1 ilist)))
      (if active-borderpixel
          (wob-borderpixel borderpixel)))))

(defun edit-plug-start ()
  (with (ilist (# 'internals wob-property)
         hook (# 'start-hook wob-property))
    (eval hook)
    (if (not (# 1 ilist))
        (## 1 ilist ""))
    (if (not (# 2 ilist))
        (## 2 ilist (# 0 ilist)))
    (edit-plug-update)))

(defun edit-plug-start-dialogue ()
  (with (ilist (# 'internals wob-property)
         hook (# 'start-hook wob-property))
    (eval hook)
    (if (not (# 1 ilist))
        (## 1 ilist ""))
    (if (not (# 2 ilist))
        (## 2 ilist (# 0 ilist)))
    (edit-plug-update)
    (with (grab-keyboard-also 1) (grab-server wob))))

(defun edit-plug-done ()
  (with (ilist (# 'internals wob-property)
         hook (# 'done-hook wob-property))
    (if (# 1 ilist) 
        (## 0 ilist (+ (# 0 ilist) (# 1 ilist))))
    (## 1 ilist ())
    (## 2 ilist ())
    (edit-plug-update)
    (ungrab-server wob)
    (setq edit-plug-result (# 0 ilist))
    (eval hook)))

(defun edit-plug-abort ()
  (with (ilist (# 'internals wob-property)
         hook (# 'abort-hook wob-property))
    (if (# 2 ilist)
        (progn
          (## 0 ilist (# 2 ilist))
          (## 1 ilist ())
          (## 2 ilist ())))
    (edit-plug-update)
    (ungrab-server wob)
    (setq edit-plug-result ())
    (eval hook)))

(defun edit-plug-insert (ch)
  (with (ilist (# 'internals wob-property))
    (## 0 ilist (+ (# 0 ilist) ch))
    (edit-plug-update)))

(defun edit-plug-delete ()
  (with (ilist (# 'internals wob-property))
    (if (# 1 ilist)
        (## 1 ilist (match ".\\(.*\\)$" (# 1 ilist) 1)))
    (edit-plug-update)))
  
(defun edit-plug-backspace ()
  (with (ilist (# 'internals wob-property))
    (if (not (= (# 0 ilist) ""))
        (## 0 ilist (match "\\(.*\\).$" (# 0 ilist) 1)))
    (edit-plug-update)))
  
(defun edit-plug-delete-rest ()
  (with (ilist (# 'internals wob-property))
    (if (# 1 ilist)
        (## 1 ilist ""))
    (edit-plug-update)))
  
(defun edit-plug-clear ()
  (with (ilist (# 'internals wob-property))
    (if (# 1 ilist)
        (## 1 ilist ""))
    (## 0 ilist "")
    (edit-plug-update)))
  
(defun edit-plug-undo ()
  (with (ilist (# 'internals wob-property))
    (if (# 1 ilist)
        (## 1 ilist ""))
    (if (# 2 ilist)
        (## 0 ilist (# 2 ilist)))
    (edit-plug-update)))
  
(defun edit-plug-eol ()
  (with (ilist (# 'internals wob-property))
    (if (# 1 ilist)
        (progn
          (## 0 ilist (+ (# 0 ilist) (# 1 ilist)))
          (## 1 ilist "")))
    (edit-plug-update)))
  
(defun edit-plug-bol ()
  (with (ilist (# 'internals wob-property))
    (## 1 ilist (if (# 1 ilist) (+ (# 0 ilist) (# 1 ilist)) (# 0 ilist)))
    (## 0 ilist "")
    (edit-plug-update)))
  
(defun edit-plug-backward ()
  (with (ilist (# 'internals wob-property))
    (if (not (= (# 0 ilist) ""))
        (progn
          (## 1 ilist (+ (match ".*\\(.\\)$" (# 0 ilist) 1)
                         (or (# 1 ilist) "")))
          (## 0 ilist (match "\\(.*\\).$" (# 0 ilist) 1))))
    (edit-plug-update)))
  
(defun edit-plug-forward ()
  (with (ilist (# 'internals wob-property))
    (if (# 1 ilist)
        (progn
          (## 0 ilist (+ (# 0 ilist)
                         (match "\\(.\\).*$" (# 1 ilist) 1)))
          (## 1 ilist (match ".\\(.*\\)$" (# 1 ilist) 1))))
    (edit-plug-update)))
  
(defun edit-plug-fit-text (str wdt)
  (with (ctx (# 'context wob-property)
         wdt (+ wdt label-horizontal-margin 1)
         pair () rest "")
    (with ctx
      (while (and (> (width str) wdt) (> (length str) 0))
        (setq pair (match "\\(.*\\)\\(.\\)$" str 1 2))
        (setq rest (+ (# 1 pair) rest))
        (setq str (# 0 pair)))
      (list str rest))))

(defun edit-plug-midstring (pair1 pair2 tot)
  (with (n1 (length (# 0 pair1))
         n2 (length (# 0 pair2))
         n (length tot)
         m (min n1 n2)
         d (abs (- n1 n2))
         reg ())
    (if (= n1 n2) ""
      (= n1 0) (# 0 pair2)
      (= n2 0) (# 0 pair1)
      (= n1 n) (# 1 pair2)
      (= n2 n) (# 1 pair1)
      t (progn
          (setq reg (+ (apply + (list-make m ".")) "\\("
                       (apply + (list-make d ".")) "\\)"))
          (match reg tot 1)))))

(defun edit-plug-xposition (pos)
  (with (ilist (# 'internals wob-property)
         str (if (# 1 ilist) (+ (# 0 ilist) (# 1 ilist)) (# 0 ilist))
         pair (edit-plug-fit-text str pos))
    (## 0 ilist (# 0 pair))
    (## 1 ilist (# 1 pair))
    (edit-plug-update)))

(defun edit-plug-xposcopy (pos)
  (with (ilist (# 'internals wob-property)
         str (if (# 1 ilist) (+ (# 0 ilist) (# 1 ilist)) (# 0 ilist))
         pair (edit-plug-fit-text str pos))
    (if (not (= (# 0 pair) (# 0 ilist)))
        (progn
          (setq cut-buffer (edit-plug-midstring ilist pair str))
          (## 0 ilist (# 0 pair))
          (## 1 ilist (# 1 pair))
          (edit-plug-update)))))

(defun edit-plug-change (str)
  (with (ilist (# 'internals wob-property))
    (## 0 ilist str)
    (if (# 1 ilist)
        (## 1 ilist ""))
    (edit-plug-update)))
  
(defun edit-plug-get ()
  (with (ilist (# 'internals wob-property))
    (if (# 1 ilist) (+ (# 0 ilist) (# 1 ilist)) (# 0 ilist))))

(defun edit-plug-query ()
  (with (edit-plug-result ())
    (send-user-event 'edit-plug-query wob)
    edit-plug-result))

(defun edit-plug-reply ()
  (setq edit-plug-result (edit-plug-get)))
  
(defun edit-plug-dialogue ()
  (with (edit-plug-result t)
    (send-user-event 'edit-plug-dialogue)
    (while (= edit-plug-result t) (process-events))
    edit-plug-result))


(setq edit-plug-active-state 
  (state-make
    (on (user-event 'edit-plug-query)
        (edit-plug-reply))
    (on (user-event 'edit-plug-done)
        (edit-plug-done)
        edit-plug-normal-state)
    (on (user-event 'edit-plug-abort)
        (edit-plug-abort)
        edit-plug-normal-state)
    (on (user-event 'edit-plug-take-focus)
        (set-focus wob))
    (on (keypress (key-make "Return") alone)
        (edit-plug-done)
        edit-plug-normal-state)
    (on (keypress (key-make "Left") alone)
        (edit-plug-backward))
    (on (keypress (key-make "Right") alone)
        (edit-plug-forward))
    (on (keypress (key-make "Home") alone)
        (edit-plug-bol))
    (on (keypress (key-make "End") alone)
        (edit-plug-eol))
    (on (keypress (key-make "Delete") alone)
        (edit-plug-backspace))
    (on (keypress (key-make "BackSpace") alone)
        (edit-plug-backspace))
    (on (keypress (key-make "Escape") alone)
        (edit-plug-abort)
        edit-plug-normal-state)
    (on (keypress (key-make "c") with-control)
        (edit-plug-abort)
        edit-plug-normal-state)
    (on (keypress (key-make "d") with-control)
        (edit-plug-delete))
    (on (keypress (key-make "f") with-control)
        (edit-plug-forward))
    (on (keypress (key-make "b") with-control)
        (edit-plug-backward))
    (on (keypress (key-make "e") with-control)
        (edit-plug-eol))
    (on (keypress (key-make "a") with-control)
        (edit-plug-bol))
    (on (keypress (key-make "k") with-control)
        (edit-plug-delete-rest))
    (on (keypress (key-make "w") with-control)
        (edit-plug-clear))
    (on (keypress (key-make "u") with-control)
        (edit-plug-undo))
    (on (keypress any any)
        (with (code (keycode-to-keysym (current-event-code) (current-event-modifier)))
          (if (and (> code 31) (< code 256))
              (edit-plug-insert (last-key)))))
    (on (buttonpress 1 alone)
        (edit-plug-xposition (current-event-relative-x)))
    (on (buttonrelease 1 alone)
        (edit-plug-xposcopy (current-event-relative-x)))
    (on (buttonpress 2 alone)
        (progn
          (edit-plug-xposition (current-event-relative-x))
          (if cut-buffer (edit-plug-insert cut-buffer))))))

(setq edit-plug-normal-state
  (state-make
    (on (user-event 'edit-plug-query)
        (edit-plug-reply))
    (on (user-event 'edit-plug-dialogue)
        (edit-plug-start-dialogue)
        edit-plug-active-state)
    (on (user-event 'edit-plug-start)
        (edit-plug-start)
        edit-plug-active-state)
    (on (user-event 'edit-plug-take-focus)
        (set-focus wob))))

(defun simple-dialogue args
  (with (prompt (or (# 0 args) "")
         def (or (# 1 args) "")
         reenter-on-opening ()
         old-borderwidth borderwidth
         old-borderpixel borderpixel
         bordertile ()
         borderpixel background
         borderwidth 1
         res ()
         mn (with (direction vertical)
              (menu-make 
                (bar-make (with (borderwidth old-borderwidth)
                            (plug-make (label-make prompt))))
                (bar-make (with (borderwidth old-borderwidth
                                 borderpixel old-borderpixel)
                            (edit-plug-make def))))))
    (if mn
        (with (dim (dimensions mn)
               x (/ (- screen-width (# 2 dim)) 2)
               y (/ (- screen-height (# 3 dim)) 2)
               wob (place-menu 'dialogue mn x y))
          (setq res (edit-plug-dialogue))
          (delete-window)
          res))))