cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-01-21 03:15:35 +01:00
Code Issues

- [GUI] fixed image positioning.

Browse Source
This commit is contained in:
cage 2023-06-07 16:31:30 +02:00
parent fe86a3f1e0
commit 8f9b4d0cf5
1 changed files with 30 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
src/gui/client/main-window.lisp
View File

@ -419,20 +419,23 @@
(let* ((file-path (slurp-iri main-window link-value)) (let* ((file-path (slurp-iri main-window link-value))
(image (gui:make-image file-path)) (image (gui:make-image file-path))
(coordinates `(+ (:line ,line-index :char 0) 1 :lines))) (coordinates `(+ (:line ,line-index :char 0) 1 :lines)))
(gui:insert-image (gemtext-widget main-window) image coordinates)
(with-accessors ((ir-lines ir-lines) (with-accessors ((ir-lines ir-lines)
(ir-rendered-lines ir-rendered-lines)) main-window (ir-rendered-lines ir-rendered-lines)
(gemtext-widget gemtext-widget)) main-window
(let* ((parent-line (elt ir-lines (- line-index 1))) (let* ((parent-line (elt ir-lines (- line-index 1)))
(new-line (copy-list parent-line))) (new-line (copy-list parent-line)))
(gui:move-cursor-to gemtext-widget coordinates)
(gui:insert-text gemtext-widget (format nil "~%"))
(gui:insert-image gemtext-widget image coordinates)
(setf (getf new-line :type) (inline-type link-value)) (setf (getf new-line :type) (inline-type link-value))
(setf ir-lines (setf ir-lines
(fresh-vector-insert@ ir-lines (fresh-vector-insert@ ir-lines
new-line new-line
line-index)) (1- line-index)))
(setf ir-rendered-lines (setf ir-rendered-lines
(fresh-vector-insert@ ir-lines (fresh-vector-insert@ ir-rendered-lines
"" ""
line-index)))))) (1- line-index)))))))
(defun inline-all-images (main-window) (defun inline-all-images (main-window)
(gui-goodies:with-busy* (main-window) (gui-goodies:with-busy* (main-window)
@ -449,7 +452,7 @@
(lambda () (lambda ()
(inline-all-images main-window))) (inline-all-images main-window)))
(defun contextual-menu-link-clrs (link-name link-value main-window line-count) (defun contextual-menu-link-clrs (link-name link-value main-window)
(labels ((add-to-tour-callback () (labels ((add-to-tour-callback ()
(ev:with-enqueued-process-and-unblock () (ev:with-enqueued-process-and-unblock ()
(comm:make-request :tour-add-link (comm:make-request :tour-add-link
@ -479,17 +482,23 @@
link-value) link-value)
:bold t) :bold t)
(client-bookmark-window:init-window main-window link-value)))) (client-bookmark-window:init-window main-window link-value))))
(open-inline-callback () (open-inline-clsr (line-number)
(if (inline-possible-p link-value) (lambda ()
(gui-goodies:with-busy* (main-window) (if (inline-possible-p link-value)
(inline-image main-window link-value line-count)) (gui-goodies:with-busy* (main-window)
(funcall (link-click-mouse-1-callback-clsr link-value main-window))))) (inline-image main-window link-value line-number))
(funcall (link-click-mouse-1-callback-clsr link-value main-window))))))
(lambda () (lambda ()
(let* ((popup-menu (gui:make-menu nil (_"link menu"))) (let* ((popup-menu (gui:make-menu nil (_"link menu")))
(x (gui:screen-mouse-x)) (x (gui:screen-mouse-x))
(y (gui:screen-mouse-y))) (y (gui:screen-mouse-y))
(relative-x (- x (gui:root-x (gemtext-widget main-window))))
(relative-y (- y (gui:root-y (gemtext-widget main-window)))))
(gui:move-cursor-to (gemtext-widget main-window)`(:x ,relative-x :y ,relative-y))
(when (inline-possible-p link-value) (when (inline-possible-p link-value)
(gui:make-menubutton popup-menu (_ "Inline") #'open-inline-callback)) (gui:make-menubutton popup-menu
(_ "Inline")
(open-inline-clsr (gui:cursor-index (gemtext-widget main-window)))))
(gui:make-menubutton popup-menu (_ "Add link to bookmarks") #'bookmark-link-callback) (gui:make-menubutton popup-menu (_ "Add link to bookmarks") #'bookmark-link-callback)
(gui:make-menubutton popup-menu (_ "Add link to tour") #'add-to-tour-callback) (gui:make-menubutton popup-menu (_ "Add link to tour") #'add-to-tour-callback)
(gui:make-menubutton popup-menu (_ "Copy link to the clipboard") #'copy-link-callback) (gui:make-menubutton popup-menu (_ "Copy link to the clipboard") #'copy-link-callback)
@ -541,7 +550,7 @@
(format nil "~a~a" prefix-other link-name)))))) (format nil "~a~a" prefix-other link-name))))))
(values link-rendered-label link-name link-value))) (values link-rendered-label link-name link-value)))
(defun colorize-emoji (main-window line-index color &optional (start 0)) (defun colorize-emoji (main-window line-index &optional (start 0))
(with-accessors ((ir-lines ir-lines) (with-accessors ((ir-lines ir-lines)
(ir-rendered-lines ir-rendered-lines) (ir-rendered-lines ir-rendered-lines)
(gemtext-widget gemtext-widget)) main-window (gemtext-widget gemtext-widget)) main-window
@ -557,9 +566,11 @@
`(:char ,(1+ i) :line ,(1+ line-index))))) `(:char ,(1+ i) :line ,(1+ line-index)))))
(gui:tag-configure gemtext-widget (gui:tag-configure gemtext-widget
tag tag
:foreground color)) :font (gui:font-create (gui::create-name)
:family "Noto Color Emoji"
:size 11))
(incf skip-index (length emoji-code-points))) (incf skip-index (length emoji-code-points)))
(incf skip-index)))))) (incf skip-index)))))))
(defun render-ir-lines (request-iri main-window) (defun render-ir-lines (request-iri main-window)
(with-accessors ((ir-lines ir-lines) (with-accessors ((ir-lines ir-lines)
@ -636,8 +647,7 @@
:button-3-callback :button-3-callback
(contextual-menu-link-clrs link-name (contextual-menu-link-clrs link-name
target-iri target-iri
main-window main-window)
line-number)
:over-callback :over-callback
(lambda () (print-info-message target-iri)) (lambda () (print-info-message target-iri))
:leave-callback :leave-callback
@ -662,6 +672,8 @@
:foreground foreground :foreground foreground
:background background :background background
:justify justification) :justify justification)
;; does not works because of a TK bug
;;(colorize-emoji main-window (1- line-number))
tag))))) tag)))))
(loop with render-line-count = 0 (loop with render-line-count = 0
with starting-pre-block-line = -1 with starting-pre-block-line = -1