mirror of https://codeberg.org/cage/tinmop/
136 lines
5.0 KiB
Common Lisp
136 lines
5.0 KiB
Common Lisp
(in-package :gui-goodies)
|
|
|
|
(cl-syntax:use-syntax 'gui-utils:nodgui-color-syntax)
|
|
|
|
(defparameter *toplevel* gui:*tk*)
|
|
|
|
(defparameter *gui-server* nil)
|
|
|
|
(defparameter *main-frame* nil)
|
|
|
|
(a:define-constant +font-h1+ "sans 20 bold" :test #'string=)
|
|
|
|
(a:define-constant +font-h2+ "sans 15 bold" :test #'string=)
|
|
|
|
(a:define-constant +font-h3+ "bold" :test #'string=)
|
|
|
|
(defgeneric parse-color (object))
|
|
|
|
(defmethod parse-color ((object symbol))
|
|
(parse-color (string-downcase (symbol-name object))))
|
|
|
|
(defmethod parse-color ((object string))
|
|
(nodgui.utils:rgb->tk (cl-colors2:as-rgb object)))
|
|
|
|
(defmethod parse-color ((object number))
|
|
(nodgui.utils:rgb->tk (cl-colors2:as-rgb object)))
|
|
|
|
(defun make-font (font-name font-size font-weight font-slant underline)
|
|
(gui:font-create (nodgui.utils:create-name)
|
|
:family font-name
|
|
:size font-size
|
|
:weight font-weight
|
|
:slant font-slant
|
|
:underline underline
|
|
:overstrike nil))
|
|
|
|
(defun gui-resize-grid-all (w)
|
|
(gui:grid-columnconfigure w :all :weight 1)
|
|
(gui:grid-rowconfigure w :all :weight 1))
|
|
|
|
(defun confirm-deletion (parent how-many)
|
|
(gui:ask-yesno (format nil (n_ "~a element will be deleted; continue?"
|
|
"~a elements will be deleted; continue?"
|
|
how-many)
|
|
how-many)
|
|
:title (_ "Confirm operation")
|
|
:parent parent))
|
|
|
|
(defun info-operation-completed (parent)
|
|
(gui:message-box (_ "Operation completed") (_ "information") :ok "info" :parent parent))
|
|
|
|
(defun info-dialog (parent message &key (title (_ "Information")))
|
|
(gui:message-box message title :ok "info" :parent parent))
|
|
|
|
(defun error-dialog (parent message &key (title (_ "Error")))
|
|
(gui:message-box message title :ok "error" :parent parent))
|
|
|
|
(defun re-validate (parent datum regex error-message)
|
|
(let* ((validator (make-instance 'validation:regexp-validator
|
|
:error-message error-message
|
|
:regexp regex))
|
|
(passedp (validation:validate validator datum)))
|
|
(if (not passedp)
|
|
(progn
|
|
(error-dialog parent error-message)
|
|
nil)
|
|
t)))
|
|
|
|
(defmacro with-re-validate ((parent &rest filters) &body body)
|
|
"each filter is -> '(datum regexp error-message)"
|
|
`(and ,@(loop for filter in filters collect
|
|
`(apply #'re-validate (list ,parent ,@filter)))
|
|
,@body))
|
|
|
|
(defmacro with-entry-text-validate ((parent &rest filters) &body body)
|
|
"filtrers -> '(entry-widget regex error-message)"
|
|
`(with-re-validate (,parent ,@(loop for filter in filters collect
|
|
`((gui:text ,(elt filter 0))
|
|
,(elt filter 1)
|
|
,(elt filter 2))))
|
|
,@body))
|
|
|
|
(defun attach-tooltip (widget tootltip-message)
|
|
(let ((tooltip (make-instance 'nodgui.mw:tooltip
|
|
:borderwidth 1
|
|
:relief :solid)))
|
|
(nodgui.mw:register-tooltip tooltip widget tootltip-message)))
|
|
|
|
(defmacro attach-tooltips (&rest widget-text)
|
|
`(progn
|
|
,@(loop for i in widget-text collect
|
|
`(attach-tooltip ,(first i) ,(second i)))))
|
|
|
|
(defmacro with-busy* ((root-widget) &body body)
|
|
`(progn
|
|
(gui:with-busy (,root-widget)
|
|
(gui:with-hourglass ,(list root-widget)
|
|
,@body))))
|
|
|
|
(defun password-dialog (parent title message &key (button-message "OK"))
|
|
(let ((res nil))
|
|
(gui:with-modal-toplevel (toplevel :title title)
|
|
(gui:transient toplevel parent)
|
|
(let* ((widget (make-instance 'gui-mw:password-entry
|
|
:show-password nil
|
|
:master toplevel))
|
|
(label (make-instance 'gui:label
|
|
:master toplevel
|
|
:text message))
|
|
(ok-button (make-instance 'gui:button
|
|
:text button-message
|
|
:master toplevel
|
|
:command (lambda ()
|
|
(setf res (gui-mw:secret-string widget))
|
|
(gui:exit-from-modal-toplevel toplevel)))))
|
|
(gui:grid label 0 0 :sticky :news)
|
|
(gui:grid widget 1 0 :sticky :news)
|
|
(gui:grid ok-button 1 1 :sticky :news)))
|
|
res))
|
|
|
|
(defclass table-frame (gui:frame)
|
|
((tree
|
|
:accessor tree
|
|
:initform nil
|
|
:initarg :tree)
|
|
(rows
|
|
:accessor rows
|
|
:initform '()
|
|
:initarg :rows)))
|
|
|
|
(defun quite-good-dialog-width (&optional (chars-unit t))
|
|
(if chars-unit
|
|
(truncate (min (/ (gui:screen-width) 2
|
|
(gui:font-measure gui:+tk-text-font+ "0"))))
|
|
(truncate (/ (gui:screen-width) 2))))
|