mirror of
https://codeberg.org/cage/tinmop/
synced 2025-03-02 09:57:48 +01:00
- fixed 'misc:fresh-vector-insert@';
- scaled inline images that nodgui can manipulates (JPEG and TGA), to fits the gemtext widget's width.
This commit is contained in:
cage
parent
82770430f8
commit
b77115d540
@ -295,6 +295,22 @@ Returns nil if the user did not provided a server in the configuration file"
|
||||
(tooter:unreblog *client*
|
||||
status-id))
|
||||
|
||||
(defun-api-call follow-tag (tag-name)
|
||||
"Follow a tag"
|
||||
(tooter:follow-tag *client* tag-name))
|
||||
|
||||
(defun-api-call unfollow-tag (tag-name)
|
||||
"Unfollow a tag"
|
||||
(tooter:unfollow-tag *client* tag-name))
|
||||
|
||||
(defun-api-call get-followed-tags (&key max-id since-id min-id (limit 20))
|
||||
"Unfollow a tag"
|
||||
(tooter:followed-tags *client*
|
||||
:max-id max-id
|
||||
:since-id since-id
|
||||
:min-id min-id
|
||||
:limit limit))
|
||||
|
||||
(define-constant +public-timeline+ "public" :test #'string=)
|
||||
|
||||
(defun-api-call get-timeline (kind &key local only-media max-id since-id min-id (limit 20))
|
||||
|
||||
@ -406,6 +406,9 @@
|
||||
((gemini-client:header-success-p status-code)
|
||||
(slurp-non-text-data main-window iri :try-to-open nil)))))))
|
||||
|
||||
(defun supports-tk-image-extension-p ()
|
||||
gui::*tkimg-loaded-p*)
|
||||
|
||||
(defun inline-image-p (link-value)
|
||||
(a:when-let* ((parsed (iri:iri-parse link-value :null-on-error t))
|
||||
(path (uri:path parsed)))
|
||||
@ -415,7 +418,8 @@
|
||||
(re:scan "(?i)jpeg$" path)
|
||||
(re:scan "(?i)png$" path)
|
||||
(re:scan "(?i)gif$" path)
|
||||
(re:scan "(?i)bmp$" path)
|
||||
(and (supports-tk-image-extension-p)
|
||||
(re:scan "(?i)bmp$" path))
|
||||
(re:scan "(?i)tga$" path)))))
|
||||
|
||||
(defun inline-possible-p (link-value)
|
||||
@ -425,44 +429,68 @@
|
||||
(when (inline-image-p link-value)
|
||||
:inline-image))
|
||||
|
||||
(defun scale-pixmap (main-window file type)
|
||||
(let* ((pixmap (nodgui.pixmap:slurp-pixmap type file))
|
||||
(gemtext-widget-width (gemtext-widget-pixel-width main-window))
|
||||
(pixmap-w (nodgui.pixmap:width pixmap))
|
||||
(ratio (/ 1 (/ pixmap-w
|
||||
(* gemtext-widget-width 1/3)))))
|
||||
(if (< ratio 1.0)
|
||||
(nodgui.pixmap:scale-bilinear pixmap ratio ratio)
|
||||
pixmap)))
|
||||
|
||||
(defun scale-jpeg (main-window file)
|
||||
(scale-pixmap main-window file 'nodgui.pixmap:jpeg))
|
||||
|
||||
(defun scale-targa (main-window file)
|
||||
(scale-pixmap main-window file 'nodgui.pixmap:tga))
|
||||
|
||||
(defun inline-image (main-window link-value line-index)
|
||||
(let* ((file-path (slurp-iri main-window (remove-standard-port link-value)))
|
||||
(image (gui:make-image file-path))
|
||||
(coordinates `(+ (:line ,line-index :char 0) 1 :lines)))
|
||||
(with-accessors ((ir-lines ir-lines)
|
||||
(ir-rendered-lines ir-rendered-lines)
|
||||
(gemtext-widget gemtext-widget)) main-window
|
||||
(let* ((parent-line (elt ir-lines (- line-index 1)))
|
||||
(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 ir-lines
|
||||
(fresh-vector-insert@ ir-lines
|
||||
new-line
|
||||
(1- line-index)))
|
||||
(setf ir-rendered-lines
|
||||
(fresh-vector-insert@ ir-rendered-lines
|
||||
""
|
||||
(1- line-index)))))))
|
||||
(multiple-value-bind (file-path mime-type)
|
||||
(slurp-iri main-window (remove-standard-port link-value))
|
||||
(let ((image (cond
|
||||
((string= mime-type +mime-type-jpg+)
|
||||
(scale-jpeg main-window file-path))
|
||||
((member mime-type '("image/x-tga" "image/x-targa"))
|
||||
(scale-targa main-window file-path))
|
||||
(t
|
||||
(gui:make-image file-path))))
|
||||
(coordinates `(+ (:line ,line-index :char 0) 1 :lines)))
|
||||
(with-accessors ((ir-lines ir-lines)
|
||||
(ir-rendered-lines ir-rendered-lines)
|
||||
(gemtext-widget gemtext-widget)) main-window
|
||||
(let* ((parent-line (elt ir-lines (- line-index 1)))
|
||||
(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 ir-lines
|
||||
(fresh-vector-insert@ ir-lines
|
||||
new-line
|
||||
line-index))
|
||||
(setf ir-rendered-lines
|
||||
(fresh-vector-insert@ ir-rendered-lines
|
||||
""
|
||||
line-index)))))))
|
||||
|
||||
(defun inline-all-images (main-window)
|
||||
"Note that this functions assumes that all remote IRI resources are
|
||||
absolute (i.e. with scheme component), non absulute IRI are considered
|
||||
local file paths."
|
||||
(gui-goodies:with-busy* (main-window)
|
||||
(loop for line across (ir-lines main-window)
|
||||
for line-number from 1
|
||||
when (and (string= (getf line :type) "a")
|
||||
(inline-image-p (getf line :href)))
|
||||
do
|
||||
(let ((link-value (if (fs:file-exists-p (getf line :href))
|
||||
(getf line :href)
|
||||
(absolutize-link (get-address-bar-text main-window)
|
||||
(getf line :href)))))
|
||||
(inline-image main-window link-value line-number)
|
||||
(incf line-number)))))
|
||||
(labels ((inline-single-image (lines line-number)
|
||||
(when (< (1- line-number) (length lines))
|
||||
(let ((line (elt lines (1- line-number))))
|
||||
(if (and (string= (getf line :type) "a")
|
||||
(inline-image-p (getf line :href)))
|
||||
(let ((link-value (if (fs:file-exists-p (getf line :href))
|
||||
(getf line :href)
|
||||
(absolutize-link (get-address-bar-text main-window)
|
||||
(getf line :href)))))
|
||||
(inline-image main-window link-value line-number)
|
||||
(inline-single-image (ir-lines main-window) (+ line-number 1)))
|
||||
(inline-single-image (ir-lines main-window) (+ line-number 1)))))))
|
||||
(inline-single-image (ir-lines main-window) 1)))
|
||||
|
||||
(defun inline-all-images-clsr (main-window)
|
||||
(lambda ()
|
||||
@ -944,7 +972,8 @@ local file paths."
|
||||
:completed)
|
||||
(if try-to-open
|
||||
(client-os-utils:open-resource-with-external-program main-window support-file)
|
||||
(getf stream-info :support-file))
|
||||
(values (getf stream-info :support-file)
|
||||
(getf stream-info :meta)))
|
||||
(wait-enough-data)))
|
||||
(buffer-filled-enough-to-open-p (buffer-size read-so-far)
|
||||
(let ((filled-configuration-threshold (and buffer-size
|
||||
@ -1431,12 +1460,17 @@ local file paths."
|
||||
|
||||
(defgeneric toc-char-width (object))
|
||||
|
||||
(defgeneric gemtext-widget-pixel-width (object))
|
||||
|
||||
(defgeneric toc-clear (object))
|
||||
|
||||
(defmethod toc-char-width ((object main-frame))
|
||||
(gui:cget (gui:listbox (toc-listbox (toc-frame object)))
|
||||
:width))
|
||||
|
||||
(defmethod gemtext-widget-pixel-width ((object main-frame))
|
||||
(gui:window-width (gui:inner-text (gemtext-widget object))))
|
||||
|
||||
(defmethod toc-clear ((object main-frame))
|
||||
(gui:listbox-delete (toc-listbox (toc-frame object))))
|
||||
|
||||
|
||||
@ -628,7 +628,7 @@ to the array"
|
||||
(defun fresh-vector-insert@ (a v pos)
|
||||
(vcat (subseq a 0 pos)
|
||||
(vector v)
|
||||
(subseq a (1+ pos))))
|
||||
(subseq a pos)))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defun make-array-frame (size &optional (el nil) (type t) (simplep nil))
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user