[ltk-user] new method listbox-delete

[Phil Armitage]

Hi Peter,

How are you?

> this mailing list is the best place I would say, as all LTk submitters

OK. All of this can be released under the LLGPL.

Disclaimers follow (!) :

1. Some of this is probably not generic enough for LTk.
2. Some of it may already be in LTk but I've just not found it.
3. Some of it could certainly be improved.
4. I use most of these in ABLE so they do work (for some definition of 'work'!)

Phil

--

;;; This replaces the current ltk implementation of this method to remove
;;; the trailing CR that Tk leaves on (for "internal reasons").
(defmethod text ((text text))
  (format-wish "senddatastring [~a get 1.0 end-1c]" (widget-path text))
  (read-data))

(defmethod get-selection-start ((txt text))
  (when (not (equal (selection-start txt) ""))
    (format-wish "senddatastring [~a index sel.first]" (widget-path txt))
    (read-data)))

(defmethod get-selection-end ((txt text))
  (when (not (equal (selection-start txt) ""))
    (format-wish "senddatastring [~a index sel.last]" (widget-path txt))
    (read-data)))

(defmethod selected ((text text))
  (when (not (equal (selection-start text) ""))
    (format-wish "senddatastring [~a get sel.first sel.last]"
(widget-path text))
    (read-data)))

(defmethod insert-text ((txt text) text &rest tags &key (position "insert"))
  (format-wish "~a insert ~a \"~a\" {~{ ~(~a~)~}}"
              (widget-path txt) position (tkescape text) tags)
  txt)

(defmethod delete-text ((txt text) start end)
  (format-wish "~a delete ~a ~a" (widget-path txt) start end))

(defmethod delete-current-char ((txt text))
  (format-wish "~a delete \"insert -1 chars\" \"insert\"" (widget-path txt)))

(defmethod get-cursor-pos ((text text))
  (format-wish "senddatastring [~a index insert]" (widget-path text))
  (read-data))

(defmethod get-visible-pos ((txt text))
  (format-wish "senddatastring [~a index \"@0,0\"]" (widget-path txt))
  (read-data))

(defgeneric set-cursor-pos (widget pos)
  (:documentation "Sets the position of the cursor in the widget"))

(defmethod set-cursor-pos ((text text) pos)
  (format-wish "~a mark set insert ~a" (widget-path text) pos))

(defmethod set-cursor-pos ((ent entry) pos)
  (format-wish "~a icursor ~a" (widget-path ent) pos))

(defmethod get-last-line-index ((txt text))
  (format-wish "senddatastring [~a index end]" (widget-path txt))
  (read-data))

(defgeneric get-text-range (object start end)
  (:documentation "Gets a sub-string from an object using the Tk style
text inices start and end"))

(defmethod get-text-range ((text text) start end)
  "Gets the sub-string by directly querying the Tk text widget"
  (format-wish "senddatastring [~a get ~a ~a]" (widget-path text) start end)
  (read-data))

(defmethod get-text-length ((txt text) start end)
  "Gets the length of text between two tk text indices. May be quicker
than sending
  the text over the process boundaries and then calling length on it."
  (format-wish "senddatastring [string length [~a get ~a ~a]]"
(widget-path txt) start end)
  (read-from-string (read-data)))

(defmethod get-text-to-cursor ((text text))
  (format-wish "senddatastring [~a get \"1.0\" \"insert\"]" (widget-path text))
  (read-data))

(defmethod get-current-word ((text text))
  (format-wish "senddatastring [~a get \"insert wordstart\" \"insert
wordend\"]" (widget-path text))
  (read-data))

(defmethod get-current-line ((text text))
  (format-wish "senddatastring [~a get \"insert linestart\" \"insert
lineend\"]" (widget-path text))
  (read-data))

(defmethod get-current-line-to-cursor ((text text))
  (format-wish "senddatastring [~a get \"insert linestart\"
\"insert\"]" (widget-path text))
  (read-data))

(defmethod get-modify ((text text))
  (format-wish "senddatastring [~a edit modified]" (widget-path text))
  (read-data))

(defmethod reset-modify ((text text))
  (format-wish "~a edit modified 0" (widget-path text)))

(defmethod un-bind ((w widget) key)
  "Unbind an event for a specific instance of a widget."
  (format-wish "bind ~a ~a {break}" (widget-path w) key))

(defun remove-binding (widget event)
  "Unbind an event for all instances of a widget class."
  (format-wish "bind ~a ~a { }" widget event))

(defmethod disable-input ((txt text))
  (format-wish "bind ~a <Any-Key> {break}" (widget-path txt)))

(defmethod enable-input ((text text))
  (format-wish "bind ~a <Any-Key> {}" (widget-path text)))

(defun withdraw-wish-toplevel ()
   (format-wish "wm withdraw ."))

(defmethod add-tag ((txt text) name start end)
  (format-wish "~a tag add ~a ~a ~a" (widget-path txt) name start end))

(defmethod remove-tag ((txt text) name start end)
  (format-wish "~a tag remove ~a ~a ~a" (widget-path txt) name start end))

(defmethod add-tags ((txt text) indexed-tokens tag-name)
  (format-wish "eval ~a tag add ~a ~a" (widget-path txt) tag-name
indexed-tokens))

(defmethod select-range ((txt text) start end)
  (format-wish "~a tag add sel ~a ~a" (widget-path txt) start end))

(defmethod select-all ((txt text))
  (format-wish "~a tag add sel 1.0 end" (widget-path txt)))

(defmethod deselect-all ((txt text))
  (format-wish "~a tag remove sel 1.0 end" (widget-path txt)))

;;; this can surely be written better...
(defun strpos-to-textidx (str end &optional (row 1) (col 0) (index 0))
  (let ((achar NIL)
        (pos (1- end)))
    (loop for c from index to pos do
      (setf achar (aref str index))
      (if (eq achar #\Newline)
          (progn (incf row)
                 (setf col 0))
          (incf col))
      (incf index))
    (values row col index)))

(defmethod event-generate ((w widget) evt)
  (format-wish "event generate ~a ~a" w evt))

(defmethod paste ((txt text))
  (format-wish "tk_textPaste ~a" (widget-path txt)))

(defun get-clipboard-text ()
  (format-wish "senddatastring [selection get -selection CLIPBOARD]")
  (read-data))

(defun create-font (name family size weight slant)
  (format-wish "font create ~a -family {~a} -size ~a -weight ~a -slant ~a"
    name family size weight slant))

(defmethod tags-configure ((txt text) tag option1 value1 option2 value2)
  (format-wish "~a tag configure ~a -~a ~a -~a ~a"
    (widget-path txt) tag option1 value1 option2 value2)
  txt)

(defmethod get-cursor-pos-as-screen-coord ((txt text))
  (format-wish "senddatastring [~a bbox insert]" (widget-path txt))
  (setq pos (read-data))
  (if (> (length pos) 0)
      pos
      nil))

(defgeneric listbox-get-selected-value (l))
(defmethod listbox-get-selected-value ((l listbox))
  (format-wish "senddata \"[~a get [~a curselection]]\"" (widget-path
l) (widget-path l))
  (read-data))



-- 
Phil Armitage
http://phil.nullable.eu/