;;; xwem-misc.el --- Misc stuff for XWEM.

;; Copyright (C) 2003 by Free Software Foundation, Inc.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: 21 Mar 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id: xwem-misc.el,v 1.6 2004/05/12 16:01:45 lg Exp $

;; This file is part of XWEM.

;; XWEM is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XWEM is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;; License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:
;;
;; This file used for misc purposes.
;;
;; If you have troubles with C-g key in Emacs, try to eval:
;;
;;    (set-input-mode nil nil nil ?\xff)
;;
;; I dont know where is bug, but sometimes my XEmacs behaves very
;; strange.  Especially after M-x C-h k.

;;; Code:
;;


(eval-and-compile
  (defvar elp-function-list nil)        ; shut up compiler
  (autoload 'elp-instrument-list "elp" nil t)
  (autoload 'elp-results "elp" nil t)
  
  (autoload 'calc-eval "calc"))

(define-error 'xwem-internal-error
  "Internal XWEM error.")

(defgroup xwem-misc nil
  "Group to customize miscellaneous options."
  :prefix "xwem-misc-"
  :group 'xwem)

(defcustom xwem-messages-buffer-name " *xwem-messages*"
  "*Buffer name for xwem messages."
  :type 'string
  :group 'xwem)

(defcustom xwem-messages-buffer-lines 1000
  "*Maximum lines in xwem messages buffer."
  :type 'number
  :group 'xwem)

(defcustom xwem-misc-functions-to-profile
  '(X-Create-message
    X-Dpy-parse-message
    string->int
    string4->int
    X-Dpy-grab-bytes
    X-Dpy-filter
    X-Dpy-parse-message-guess
    accept-process-output
    X-Text-width
    X-Text-height
    XImagePut)
  "List of functions to profile using xwem profiler."
  :type '(repeat function)
  :group 'xwem-misc)

;;; Cursors
(defgroup xwem-cursor nil
  "Group to customize cursors in XWEM."
  :prefix "xwem-cursor-"
  :group 'xwem)

;; Default cursor
(defcustom xwem-cursor-default-shape 'X-XC-left_ptr
  "*Shape of default xwem cursor."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-default-foreground-color "#002800"
  "*Default cursor's foreground color."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-default-background-color "#000000"
  "*Default cursor's background color."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; wait cursor
(defcustom xwem-cursor-wait-shape 'X-XC-icon
  "*Shape of cursor, when XWEM wait for something."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-wait-foreground-color "#ea0000"
  "*Cursor's foreground color when XWEM wait for something."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-wait-background-color nil;"#280000"
  "*Cursor's background color when XWEM waiit for something."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; move cursor
(defcustom xwem-cursor-move-shape 'X-XC-fleur
  "*Shape of cursor, when moving something."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-move-foreground-color "#777777"
  "*Cursor's foreground color when moving something."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-move-background-color nil;"#280000"
  "*Cursor's background color when moving something."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; quote cursor
(defcustom xwem-cursor-quote-shape 'X-XC-sb_down_arrow
  "*Shape of cursor, when XWEM quoting keyboard or mouse."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-quote-foreground-color "#0000BB"
  "*Cursor's foreground color when XWEM quoting keyboard/mouse."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-quote-background-color "#000099"
  "*Cursor's background color when XWEM quoting keyboard/mouse."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; help cursor
(defcustom xwem-cursor-help-shape 'X-XC-question_arrow
  "*Shape of cursor, when getting help with XWEM."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-help-foreground-color "#00BB00"
  "*Cursor's foreground color when quering XWEM for help."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-help-background-color "#009900"
  "*Cursor's background color when quering XWEM for help."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; cursor storages
;;;###autoload
(defvar xwem-cursor-fnt nil "Font for \"cursor\" series.")

;;;###autoload
(defvar xwem-cursor-default nil "Default cursor.")
;;;###autoload
(defvar xwem-cursor-left nil "Left cursor.")
;;;###autoload
(defvar xwem-cursor-right nil "Right cursor.")
;;;###autoload
(defvar xwem-cursor-wait nil "Cursor when we are wait.")
;;;###autoload
(defvar xwem-cursor-drag nil "Cursor when we drag.  Drug is a bad idea.")
;;;###autoload
(defvar xwem-cursor-move nil "Cursor when we move something.")
;;;###autoload
(defvar xwem-cursor-resize nil "Cursor when we resize.")
;;;###autoload
(defvar xwem-cursor-quote nil "Cursor when quoting key.")
;;;###autoload
(defvar xwem-cursor-help nil "Cursor when in help mode.")

;;; Functions
;;;###autoload
(defsubst xwem-misc-colorspec->rgb-vector (colspec)
  "Conver color specification COLSPEC to internal representation.
COLSPEC maybe in form: #RRGGBB or name like 'green4'."
  (vconcat (color-instance-rgb-components (make-color-instance colspec))))

;;;###autoload
(defsubst xwem-misc-colorspec->rgb-vector-safe (colspec &optional defret)
  "Validate COLSPEC to be color specification in safe manner.
Return DEFRET or [0 0 0] if there was error."
  (condition-case nil
      (xwem-misc-colorspec->rgb-vector colspec)
    (t (or defret [0 0 0]))))

;;;###autoload
(defsubst xwem-misc-colorspec-valid-p (colspec)
  "Return non-nil if COLSPEC is valid color specification.
Valid colorspecification is spec in form: #RRGGBB or name like 'green4'."
  (condition-case nil
      (xwem-misc-colorspec->rgb-vector colspec)
    (t nil)))

;;;###autoload
(defun xwem-make-cursor (type &optional fgcol bgcol)
  "Make new cursor of TYPE and store it in WHERE-STORE.
BGCOL maybe nil, that mean masking will not be done."
  (let ((fgc (xwem-misc-colorspec->rgb-vector-safe fgcol [0 0 0]))
        (bgc (xwem-misc-colorspec->rgb-vector-safe bgcol 'invalid-bgcol))
        cursor)
    (setq cursor (make-X-Cursor :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy))
                                :source xwem-cursor-fnt
                                :mask xwem-cursor-fnt
                                :src-char type
                                :msk-char (+ (if (eq bgc 'invalid-bgcol) 0 1) type)
                                :fgred (aref fgc 0)
                                :fggreen (aref fgc 1)
                                :fgblue (aref fgc 2)))
    (unless (eq bgc 'invalid-bgcol)
      (setf (X-Cursor-bgred cursor) (aref bgc 0))
      (setf (X-Cursor-bggreen cursor) (aref bgc 1))
      (setf (X-Cursor-bgblue cursor) (aref bgc 2)))

    (XCreateGlyphCursor (xwem-dpy) cursor)
    cursor))

;;;###autoload
(defun xwem-init-cursors ()
  "Initialize cursors."
  ;; Make cursors
  (xwem-message 'msg "Initializing cursors ... wait")

  (setq xwem-cursor-fnt (make-X-Font :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy))
                                     :name "cursor"))
  (XOpenFont (xwem-dpy) xwem-cursor-fnt)

  (setq xwem-cursor-default (xwem-make-cursor (eval xwem-cursor-default-shape)
                                              xwem-cursor-default-foreground-color
                                              xwem-cursor-default-background-color)

        xwem-cursor-left (xwem-make-cursor X-XC-left_ptr
                                           xwem-cursor-default-foreground-color
                                           xwem-cursor-default-background-color)

        xwem-cursor-right (xwem-make-cursor X-XC-right_ptr
                                            xwem-cursor-default-foreground-color
                                            xwem-cursor-default-background-color)

        xwem-cursor-wait (xwem-make-cursor (eval xwem-cursor-wait-shape)
                                           xwem-cursor-wait-foreground-color
                                           xwem-cursor-wait-background-color)

        xwem-cursor-move (xwem-make-cursor (eval xwem-cursor-move-shape)
                                           xwem-cursor-move-foreground-color
                                           xwem-cursor-move-background-color)

        xwem-cursor-quote (xwem-make-cursor (eval xwem-cursor-quote-shape)
                                            xwem-cursor-quote-foreground-color
                                            xwem-cursor-quote-background-color)

        xwem-cursor-help (xwem-make-cursor (eval xwem-cursor-help-shape)
                                           xwem-cursor-help-foreground-color
                                           xwem-cursor-help-background-color))
  ;; TODO: add other cursors
  )

;;; Misc drawing
;;;###autoload
(defun xwem-misc-draw-shadow (dpy win gc1 gc2 x y w h thick)
  "Draw shadow."
  (let ((offset 0)
        s1 s2)
    (if (or (> (* thick 2) h) (> (* thick 2) w))
        nil                             ; undrawable
      (while (not (= thick offset))
        (setq s1 (cons (cons (make-X-Point :xx (+ x offset) :yy (+ y offset))
                             (make-X-Point :xx (+ x offset) :yy (- (+ y h) offset 1)))
                       s1))
        (setq s1 (cons (cons (make-X-Point :xx (+ x offset) :yy (+ y offset))
                             (make-X-Point :xx (- (+ x w) offset 1) :yy (+ y offset)))
                       s1))

        (setq s2 (cons (cons (make-X-Point :xx (+ x offset) :yy (- (+ y h) offset 1))
                             (make-X-Point :xx (- (+ x w) offset 1) :yy (- (+ y h) offset 1)))
                       s2))
        (setq s2 (cons (cons (make-X-Point :xx (- (+ x w) offset 1) :yy (+ y offset 1))
                             (make-X-Point :xx (- (+ x w) offset 1) :yy (- (+ y h) offset 1)))
                       s2))

        (setq offset (+ offset 1)))

      (when s1
        (XDrawSegments dpy win gc1 s1))
      (when s2
        (XDrawSegments dpy win gc2 s2))
      )))

;;;###autoload
(defun xwem-misc-draw-bar (dpy win gc1 gc2 gc3 x y w h th)
  "Draw shadowed bar.
Bar filled with GC1.
Shadow thickness is TH and it is drawed with GC2 and GC3."
  (X-Dpy-log dpy "xwem-misc-draw .. x=%d y=%d w=%d h=%d\n" 'x 'y 'w 'h)

  (xwem-misc-draw-shadow dpy win gc2 gc3 x y w h th)
  (XFillRectangle dpy win gc1 (+ x th) (+ y th) (- w (* th 2)) (- h (* th 2)))
  )

;;;###autoload
(defun xwem-misc-find-frame (name)
  "Find Emacs frame by its NAME."
  (let ((fl (frame-list))
        (rf nil))

    (while fl
      (when (string= (frame-name (car fl)) xwem-minibuffer-name)
        ;; Found
        (setq rf (car fl))
        (setq fl nil))
      (setq fl (cdr fl)))
    rf))

;; Some hooks
(eval-when-compile
  (autoload 'X-Event-seq "xlib-xr"))

;;;###autoload
(defun xwem-misc-xwin-valid-p (xwin)
  "Return non-nil if XWIN is valid X window.
Do it in safe manner."
  (let (attrs)
    (X-Dpy-put-property (X-Win-dpy xwin) 'xwem-ignore-bad-win t)
    (unwind-protect
        (setq attrs (XGetWindowAttributes (X-Win-dpy xwin) xwin))
      (X-Dpy-put-property (X-Win-dpy xwin) 'xwem-ignore-bad-win nil))
    attrs))

;;;###autoload
(defun xwem-misc-xerr-hook (xdpy xev)
  "Display X errors in `xwem-minibuffer'.
Error hook must not performe any interaction with X server!
XDPY - X-Dpy.
XEV  - X-Event of error type."
  (let* ((err (X-Event-xerror-code xev))
         (badth (X-Event-xerror-resourceid xev))
         (seq (X-Event-seq xev))
         (maj (X-Event-xerror-maj-op xev))
         (min (X-Event-xerror-min-op xev))
         (bstr (cond ((= err 1) "Request")
                     ((= err 2) "Value")
                     ((= err 3) "Window")
                     ((= err 4) "Pixmap")
                     ((= err 5) "Atom")
                     ((= err 6) "Cursor")
                     ((= err 7) "Font")
                     ((= err 8) "Match")
                     ((= err 9) "Drawable")
                     ((= err 10) "Access")
                     ((= err 11) "Alloc")
                     ((= err 12) "Color")
                     ((= err 13) "GC")
                     ((= err 14) "IDChoice")
                     ((= err 15) "Name")
                     ((= err 16) "Length")
                     ((= err 17) "Implementation")
                     ((= err 128) "FirstExtension")
                     ((= err 255) "LastExtension")
                     (t "Unknown"))))
    (unless (and (X-Dpy-get-property xdpy 'xwem-ignore-bad-win)
                 (eq err 3))
      (xwem-message 'err "X error - Bad %s %f seq=%f:%d ops=%d:%d"
                    bstr badth seq (X-Dpy-rseq-id (xwem-dpy)) maj min)
    )))

;;;###autoload
(defun xwem-init-misc ()
  "Some misc initializetions."
  (pushnew 'xwem-misc-xerr-hook (X-Dpy-error-hooks (xwem-dpy)))
  )

;;; Stuff for debugging
(defun xwem-misc-str2hexstr (str)
  "Convert STR to hexidecimal string representation."
  (substring (mapconcat (lambda (el) (format "%x " el)) str "") 0 -1))

;;; Messaging

;;;###autoload
(defun xwem-str-with-faces (str face-list)
  "Return STR with applied FACE-LIST."
  (let ((ext (make-extent 0 (length str) str)))

    (set-extent-property ext 'duplicable t)
    (set-extent-property ext 'unique t)
    (set-extent-property ext 'start-open t)
    (set-extent-property ext 'end-open t)
    (set-extent-property ext 'face face-list))
  str)

(defun xwem-format-faces (fmt def-face &rest args)
  "Accepts format FMT and ARGS in form `((arg . face) ...)'.
DEF-FACE is default face. Returns string with faces."
  (let ((flst (string-to-list fmt))
        (chr nil)
        (rstr ""))
    (while flst
      (setq chr (car flst))
      (cond ((= chr ?%)
             (setq flst (cdr flst))
             (setq chr (car flst))
             (let ((arg (if (consp (car args)) (caar args) (car args)))
                   (fcs (if (consp (car args)) (cdr (car args)) nil)))
               (cond ((= chr ?s)
                      (setq rstr (concat
                                  rstr
                                  (xwem-str-with-faces
                                   arg
                                   (if fcs (list fcs def-face) (list def-face)))))
                    (setq args (cdr args)))

                   ((= chr ?d)
                    (setq rstr (concat
                                rstr
                                (xwem-str-with-faces
                                 (int-to-string arg)
                                 (if fcs (list fcs def-face) (list def-face)))))
                    (setq args (cdr args)))
                    (t nil))))
            (t
             (setq rstr (concat
                         rstr
                         (xwem-str-with-faces (char-to-string chr) (list def-face))))))
      (setq flst (cdr flst)))

    rstr))

(defun xwem-message-insert (message)
  "Insert MESSAGE in `xwem-messages-buffer-name' buffer."
  (with-current-buffer (get-buffer-create xwem-messages-buffer-name)
    (let ((inhibit-read-only t))
      ;; Remove all messages from buffer if it exided maximum value
      (when (> (count-lines-buffer) xwem-messages-buffer-lines)
        (delete-region (point-min) (point-max)))

      (goto-char (point-max))
      (insert (format-time-string "%D %T: "))
      (insert message)
      (insert "\n"))))

;;;###autoload
(defun xwem-message (type fmt &rest args)
  "Display xwem message of TYPE using FMT format.
Type is:
'note -- For some xwem notes.
'warn -- For xwem warnings (beeps).
'warn-nobeep -- For xwem warnings (does not beeps).
'err  -- For xwem warnings (beeps).
'err-nobeep  -- For xwem warnings (does not beeps).
'todo -- Things that xwem should have.
'msg  -- Informatical message.
'prompt -- XWEM's input prompt.
'asis -- Such type is not passed through `format', ARGS should be nil,
         used to message colorized text.

ARGS are passed to `format' with FMT to generate final message."
  (if (eq type 'asis)
      (display-message 'message fmt)
    (let ((str
           (cond ((eq type 'note) "-Note:")
                 ((eq type 'warn)
                  (concat "-" (xwem-str-with-faces "Warning:" (list 'red))))
                 ((eq type 'warn-nobeep)
                  (concat "-" (xwem-str-with-faces "Warning:" (list 'red))))
                 ((eq type 'err)
                  (concat "-" (xwem-str-with-faces "Error:" (list 'red 'bold))))
                 ((eq type 'err-nobeep)
                  (concat "-" (xwem-str-with-faces "Error:" (list 'red 'bold))))
                 ((eq type 'todo) (concat "-" (xwem-str-with-faces "TODO:" (list 'bold))))
                 ((eq type 'msg) "")
                 ((eq type 'prompt) "")
                 ((eq type 'progress) "")
                 ((eq type 'nolog) "")
                 (t "")))
          (msg (apply 'format fmt args)))

      (unless (member type '(prompt progress nolog))
        (xwem-message-insert msg))

      ;; Beep if needed
      (cond ((eq type 'warn) (xwem-play-sound 'msg-warn))
            ((eq type 'err) (xwem-play-sound 'msg-err)))

      (display-message 'message (concat "XWEM" str " " msg)))))

;;;###autoload
(defun xwem-clear-message ()
  "Just as `clear-message'."
  (clear-message))

;;;###autoload(autoload 'xwem-show-message-log "xwem-misc")
(define-xwem-command xwem-show-message-log (arg)
  "Show `xwem-messages-buffer-name'.
If prefix ARG is given, than behaviour is undefined."
  (xwem-interactive "P")

  (let ((mbuf (get-buffer-create xwem-messages-buffer-name)))
    (xwem-special-popup-frame mbuf)
    (with-current-buffer mbuf
      (setq mode-name "XWEM-log")
      (local-set-key (kbd "q") 'delete-frame)
      (message "Press `q' to eliminate buffer.")
      )))

;;;###autoload
(defun xwem-list-to-string (list len)
  "Convert LIST of characterters to string with length LEN."
  (let ((rstr ""))
    (while (and list (> len 0))
      (setq rstr (concat rstr (string (car list))))
      (setq list (cdr list))
      (setq len (1- len)))
    rstr))

;;;; Misc commands.
;;;###autoload(autoload 'xwem-ignore-command "xwem-misc")
(define-xwem-command xwem-ignore-command ()
  "Generic ignore command."
  (xwem-interactive))
  
(defvar xwem-read-expression-history nil
  "*History of expressions evaled using `xwem-eval-expression'.")

;;;###autoload(autoload 'xwem-eval-expression "xwem-misc")
(define-xwem-command xwem-eval-expression (expr &optional arg)
  "Eval Lisp expression interactively.
When used with prefix ARG, then insert the result into selected client."
  (xwem-interactive (list
                     (xwem-read-from-minibuffer (if xwem-prefix-arg
                                                    "XWEM (insert) Eval: "
                                                  "XWEM Eval: ")
                                                nil read-expression-map
                                                t 'xwem-read-expression-history)
                     xwem-prefix-arg))

  (setq values (cons (eval expr) values))
  (if arg
      (xwem-key-send-ekeys (prin1-to-string (car values)))
    
    (xwem-message 'info "%S => %S" expr (car values))))

;;;###autoload(autoload 'xwem-execute-extended-command "xwem-misc")
(define-xwem-command xwem-execute-extended-command (arg)
  "Execute Emacs command.
If prefix ARG is given insert result to current client."
  (xwem-interactive "P")

  (flet ((read-from-minibuffer (&rest args) nil))
    (fset 'read-from-minibuffer (symbol-function 'xwem-read-from-minibuffer))
    (let ((retval (execute-extended-command arg)))
      (when arg
        (xwem-key-send-ekeys (pp retval))))))

;;;###autoload(autoload 'xwem-shell-command "xwem-misc")
(define-xwem-command xwem-shell-command (command arg)
  "Execute shell command, just as `shell-command' do.
If prefix ARG is given insert result to current client.
If output of COMMAND fits to one string it is displayed in
`xwem-minibuffer', if not Emacs special frame will be poped up with
contents of COMMAND output.
If double prefix ARG \(i.e. \\<xwem-global-map>\\[xwem-universal-argument] \\<xwem-global-map>\\[xwem-universal-argument]\) supplied, then last
'\\n' character will be cuted in output to current client."
  (xwem-interactive (list (xwem-read-shell-command "XWEM Shell command: ")
                          xwem-prefix-arg))

  ;; Create temporary
  (let ((tbuf (get-buffer-create (generate-new-buffer-name " *temp-buf*")))
        dontkill)
    (unwind-protect
        (with-current-buffer tbuf
          (call-process shell-file-name nil tbuf nil
                        shell-command-switch command)

          (if arg
              (xwem-key-send-ekeys (buffer-substring (point-min)
                 (- (point-max) (if (> (prefix-numeric-value arg) 4) 1 0))))

            (if (= 1 (count-lines (point-min) (point-max)))
                (xwem-message 'info (buffer-substring (point-min) (point-max)))

              (xwem-special-popup-frame tbuf)
              (setq dontkill t))))
      (unless dontkill
        (kill-buffer tbuf)))))
    
;;;###autoload(autoload 'xwem-mini-calc "xwem-misc")
(define-xwem-command xwem-mini-calc (expr &optional arg)
  "Calculate expression EXPR.
If prefix ARG is given, insert the result to current client."
  (xwem-interactive
   (list (xwem-read-from-minibuffer (if xwem-prefix-arg
                                        "XWEM (insert) Calc: "
                                      "XWEM Calc: "))
         xwem-prefix-arg))

  (let ((result (calc-eval expr)))
    (if arg
        (xwem-key-send-ekeys result)
      (xwem-message 'info "%s = %s" expr result))))

;;;###autoload(autoload 'xwem-beginning-of-cl "xwem-misc")
(define-xwem-command xwem-beginning-of-cl ()
  "Send Home key to selected client."
  (xwem-interactive "*_")

  (xwem-kbd-force-mods-release)
  (xwem-key-send-ekeys (vector 'home)))

;;;###autoload(autoload 'xwem-end-of-cl "xwem-misc")
(define-xwem-command xwem-end-of-cl ()
  "Send End key to current client."
  (xwem-interactive "*_")

  (xwem-kbd-force-mods-release)
  (xwem-key-send-ekeys (vector 'end)))

;;;###autoload(autoload 'xwem-misc-make-screenshot "xwem-misc")
(define-xwem-command xwem-misc-make-screenshot (file-name)
  "Make screen screenshot and save it to file with NAME."
  (xwem-interactive "FImport screen to file: ")

   (flet ((message (fmt &rest args) nil))
     ;; shut up messaging
     (xwem-message 'msg
                   (format "Importing screenshot to %s." file-name))
     (xwem-execute-program (format "import -window root %s" (expand-file-name file-name)))))

;;;###autoload(autoload 'xwem-misc-pause "xwem-misc")
(define-xwem-command xwem-misc-pause (arg)
  "Pause for ARG decaseconds(0.1 sec).
This command is usefull, when recording keyboard macro, and there need
to wait for something, f.e. window mapping."
  (xwem-interactive "p")

  (while (> arg 0)
    (sleep-for 0.1)
    ;; Try to accept some data, so incoming events would be processed
    (accept-process-output (X-Dpy-proc (xwem-dpy)) 0.01)
    (setq arg (1- arg))))

;;; Some useful operations on lists
(defun xwem-insert-after (list aft-el el)
  "In LIST after AFT-EL insert EL."
  (push el (cdr (member aft-el list)))
  list)

(defun xwem-insert-before (list bef-el el)
  "In LIST before BEF-EL insert EL."
  (nreverse (xwem-insert-after (nreverse list) bef-el el)))

(defun xwem-list-set-element (list old-el new-el)
  "In LIST set OLD-EL to NEW-EL."
  (setcar (member old-el list) new-el)
  list)

;;;###autoload
(defun xwem-list-exchange-els (list el1 el2)
  "In LIST exchange places of EL1 and EL2."
  (when (or (null (member el1 list))
            (null (member el2 list)))
    (error "El1 or el2 is not in list"))

  (xwem-list-set-element list el1 'this-fake-name1-should-not-be-in-list)
  (xwem-list-set-element list el2 el1)
  (xwem-list-set-element list 'this-fake-name1-should-not-be-in-list el2))

;;; Profiling support
;;;###autoload
(defun xwem-misc-start-profiling ()
  "Start profiling critical xlib/xwem functions."
  (interactive)

  (setq elp-function-list xwem-misc-functions-to-profile)
  (elp-instrument-list))

;;;###autoload
(defun xwem-misc-profiling-results ()
  "Show xlib/xwem profiling results."
  (interactive)
  (elp-results))

;;;###autoload
(defun xwem-recursive-edit ()
  "Enter recursive edit."
  (recursive-edit))

;;;###autoload
(defun xwem-exit-recursive-edit ()
  "Exit from recursive edit."
  (if (> (recursion-depth) 0)
      (throw 'exit nil))
  (xwem-message 'warn "No recursive edit is in progress"))


;;; Text Specifications operations

;; TextSpec is list of vectors:
;; - vectors elements is cons cells in form (face . "text")
;; - each vector specifies line
;; - empty vector specifies newline

;;;###autoload
(defun xwem-misc-line->linesp (default-face)
  "Convert current line in selected buffer to element of text spec - line spec.
DEFAULT-FACE is the default face."
  (let (tsp cpnt npnt face str)
    (save-excursion
      (narrow-to-region (point-at-bol) (point-at-eol))
      (goto-char (point-at-bol))
      (while (not (eolp))
        (setq cpnt (point)
              npnt (or (next-single-property-change cpnt 'face) (point-at-eol))
              face (or (get-char-property cpnt 'face) default-face)
              str (buffer-substring cpnt npnt))
        (when (consp face)
          (setq face (car face)))       ; XXX need face merging
        
        ;; XXX Untabify
        (setq str (replace-in-string str "\t" (make-string tab-width ?\x20)))

        (setq tsp (cons (cons face str) tsp))
        (goto-char npnt))
      (widen))
    (vconcat (nreverse (or tsp (list (cons default-face "")))))))

;;;###autoload
(defun xwem-misc-buffer->textsp (default-face &optional buffer start end)
  "Convert BUFFER to text specification.
DEFAULT-FACE is the default face.
If BUFFER is omitted, selected buffer assumed."
  (let (rlst)
    (save-excursion
      (when buffer
        (set-buffer buffer))

      (goto-char (or start (point-min)))
      (while (and (not (eobp))
                  (< (point) (or end (point-max))))
        (setq rlst (cons (xwem-misc-line->linesp default-face) rlst))
        (forward-line 1))
      )
    (nreverse rlst)))

;;;###autoload
(defun xwem-misc-linesp-width (linesp)
  "Return width of line spec LINESP."
  (apply '+ (mapcar (lambda (el)
                      (X-Text-width (xwem-dpy) (X-Gc-font (xwem-face-get-gc (car el)))
                                    (cdr el)))
                    linesp)))

;;;###autoload
(defun xwem-misc-linesp-height (linesp)
  "Return height of line spec LINESP."
  (apply 'max (mapcar (lambda (el)
                        (X-Text-height (xwem-dpy) (X-Gc-font (xwem-face-get-gc (car el)))
                                       (cdr el)))
                      linesp)))

;;;###autoload
(defun xwem-misc-linesp-show (xwin x y linesp &optional type default-background)
  "In x window XWIN at X and Y coordinates show line spec LINESP.
TYPE is one of XImageString or XDrawString, default is XImageString."
  (let ((cxoff 0))
    (mapc (lambda (el)
            (funcall (cond ((and (eq type 'XDrawString)
                                 (stringp default-background)
                                 (not (string= default-background (face-background-name (car el)))))
                            'XImageString)
                           ((not (null type)) type)
                           (t 'XImageString))
                     (X-Win-dpy xwin) xwin
                     (xwem-face-get-gc (car el))
                     (+ x cxoff) y (cdr el))
            (setq cxoff (+ cxoff (X-Text-width (X-Win-dpy xwin)
                                               (X-Gc-font (xwem-face-get-gc (car el))) (cdr el)))))
          linesp)))

;;;###autoload
(defun xwem-misc-textsp-show (xwin x y textsp &optional type default-background)
  "In x window XWIN at X and Y coordinates show text spec TEXTSP.
TYPE is one of XImageString or XDrawString, default is XImageString.
If TYPE is XDrawString and DEFAULT-BACKGROUND is specifed, characters
that have different than DEFAULT-BACKGROUND baground color are drawed
using XImageString."
  (let ((yoff 0))
    (X-Dpy-send-excursion (X-Win-dpy xwin)
      (mapc (lambda (el)
              (xwem-misc-linesp-show xwin x (+ y yoff) el type default-background)
              (setq yoff (+ yoff (xwem-misc-linesp-height el))))
            textsp)
      )))

;;; Outlining
(defface xwem-misc-outline-face1
  `((t (:foreground "white" :background "black" :function X-GXXor :subwindow-mode X-IncludeInferiors :line-width 4)))
  "Face used to outline something."
  :group 'xwem-faces)

(defface xwem-misc-outline-face2
  `((t (:foreground "white" :background "black" :function X-GXXor :subwindow-mode X-IncludeInferiors :line-width 2)))
  "Face used to outline something."
  :group 'xwem-faces)

;;;###autoload
(defun xwem-misc-outline (xrect how)
  "Outline XRECT using HOW method.
Valid HOW is 'normal, ..."
  (let ((x (X-Rect-x xrect))
        (y (X-Rect-y xrect))
        (w (X-Rect-width xrect))
        (h (X-Rect-height xrect)))
    (cond ((eq how 'normal)
           (XDrawRectangles (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face1) (list xrect)))

          ((eq how 'contiguous)
           (xwem-misc-outline xrect 'normal)
           (XDrawSegments (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face2)
                          (list (cons (cons x 0)
                                      (cons x (X-Geom-height (xwem-rootgeom))))
                                (cons (cons (+ x w) 0)
                                      (cons (+ x w) (X-Geom-height (xwem-rootgeom))))
                                (cons (cons 0 y)
                                      (cons (X-Geom-width (xwem-rootgeom)) y))
                                (cons (cons 0 (+ y h))
                                      (cons (X-Geom-width (xwem-rootgeom)) (+ y h)))
                                )))

          ((eq how 'corners)
           (let* ((cornw (/ w 8))
                  (cornh (/ h 8))
                  (crw (/ (+ cornh cornw) 2)))
             (XDrawSegments (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face1)
                            (list 
                             ;; Top left
                             (cons (cons x y) (cons (+ x cornw) y))
                             (cons (cons x y) (cons x (+ y cornh)))

                             ;; Top right
                             (cons (cons (+ x w) y) (cons (+ x w (- cornw)) y))
                             (cons (cons (+ x w) y) (cons (+ x w) (+ y cornh)))

                             ;; Bottom left
                             (cons (cons x (+ y h)) (cons (+ x cornw) (+ y h)))
                             (cons (cons x (+ y h)) (cons x (+ y h (- cornh))))
                                
                             ;; Bottom right
                             (cons (cons (+ x w) (+ y h)) (cons (+ x w (- cornw)) (+ y h)))
                             (cons (cons (+ x w) (+ y h)) (cons (+ x w) (+ y h (- cornh))))

                             ;; Crosshair
                             (cons (cons (+ x (/ (- w crw) 2)) (+ y (/ h 2))) (cons (+ x (/ (+ w crw) 2)) (+ y (/ h 2))))
                             (cons (cons (+ x (/ w 2)) (+ y (/ (- h crw) 2))) (cons (+ x (/ w 2)) (+ y (/ (+ h crw) 2))))
                             ))))

          ((eq how 'grid)
           (xwem-misc-outline xrect 'normal)
           (XDrawSegments (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face2)
                          (nconc (funcall (lambda ()
                                            (let ((off 0) rl)
                                              (while (< off (+ x w))
                                                (when (> off x)
                                                  (setq rl (cons (cons (cons off y) (cons off (+ y h))) rl)))
                                                (setq off (+ off 64)))
                                              rl)))
                                 (funcall (lambda ()
                                            (let ((off 0)
                                                  rl)
                                              (while (< off (+ y h))
                                                (when (> off y)
                                                  (setq rl (cons (cons (cons x off) (cons (+ x w) off)) rl)))
                                                (setq off (+ off 64)))
                                              rl)))))
           )

          ;; TODO: add others
          )))


(provide 'xwem-misc)

;;; xwem-misc.el ends here
