├── .gitattributes
├── .gitignore
├── .travis.yml
├── LICENSE
├── README.md
├── gallery.lisp
├── halftone.asd
├── images.lisp
├── main.lisp
├── package.lisp
└── viewer.lisp
/.gitattributes:
--------------------------------------------------------------------------------
1 |
2 | doc/ linguist-vendored
3 |
--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | bin/
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | language: common-lisp
2 |
3 | sudo: false
4 |
5 | env:
6 | global:
7 | - PATH=~/.roswell/bin:$PATH
8 | - ROSWELL_INSTALL_DIR=$HOME/.roswell
9 | matrix:
10 | - LISP=sbcl-bin
11 |
12 | install:
13 | - curl -L https://raw.githubusercontent.com/roswell/roswell/release/scripts/install-for-ci.sh | sh
14 |
15 | cache:
16 | directories:
17 | - $HOME/.roswell
18 | - $HOME/.config/common-lisp
19 |
20 | script:
21 | # X server
22 | - export DISPLAY=:99.0
23 | - sh -e /etc/init.d/xvfb start
24 | # Build binary
25 | - ros -s qtools -s halftone -e '(asdf:make :halftone :force T)'
26 |
27 | notifications:
28 | email:
29 | - shinmera@tymoon.eu
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2015 Nicolas Hafner
2 |
3 | This software is provided 'as-is', without any express or implied
4 | warranty. In no event will the authors be held liable for any damages
5 | arising from the use of this software.
6 |
7 | Permission is granted to anyone to use this software for any purpose,
8 | including commercial applications, and to alter it and redistribute it
9 | freely, subject to the following restrictions:
10 |
11 | 1. The origin of this software must not be misrepresented; you must not
12 | claim that you wrote the original software. If you use this software
13 | in a product, an acknowledgment in the product documentation would be
14 | appreciated but is not required.
15 | 2. Altered source versions must be plainly marked as such, and must not be
16 | misrepresented as being the original software.
17 | 3. This notice may not be removed or altered from any source distribution.
18 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | About Halftone 
2 | --------------
3 | This is a simple image viewer application written in Common Lisp, using the Qt framework.
4 |
5 | 
6 |
--------------------------------------------------------------------------------
/gallery.lisp:
--------------------------------------------------------------------------------
1 | #|
2 | This file is a part of halftone
3 | (c) 2015 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
4 | Author: Nicolas Hafner
5 | |#
6 |
7 | (in-package #:org.shirakumo.halftone)
8 | (in-readtable :qtools)
9 |
10 | (define-widget thumbnail (QWidget)
11 | ((file :initarg :file :accessor file)
12 | (selected :initarg :selected :accessor selected))
13 | (:default-initargs
14 | :file (error "FILE required.")
15 | :selected NIL))
16 |
17 | (define-signal (thumbnail do-update) ())
18 |
19 | (defmethod (setf selected) :after (val (thumbnail thumbnail))
20 | (signal! thumbnail (do-update)))
21 |
22 | (define-initializer (thumbnail setup)
23 | (setf (q+:fixed-size thumbnail) (values 128 128))
24 | (connect! thumbnail (do-update) thumbnail (update)))
25 |
26 | (define-subwidget (thumbnail image) NIL
27 | (with-callback-task (thumbnail-loader-task :file file) (result)
28 | (setf image result)
29 | (signal! thumbnail (do-update))))
30 |
31 | (define-override (thumbnail paint-event) (ev)
32 | (declare (ignore ev))
33 | (with-finalizing ((painter (q+:make-qpainter thumbnail)))
34 | (let ((brush (if selected
35 | (q+:highlight (q+:palette thumbnail))
36 | (q+:window (q+:palette thumbnail)))))
37 | (q+:fill-rect painter (q+:rect thumbnail) brush))
38 | (when image
39 | (let ((target (q+:rect thumbnail)))
40 | (q+:adjust target 5 5 -5 -5)
41 | (q+:draw-image painter target image (q+:rect image))))))
42 |
43 | (define-override (thumbnail mouse-release-event) (ev)
44 | (when (= (enum-value (q+:button ev)) (q+:qt.left-button))
45 | (setf (image *main*) file))
46 | (stop-overriding))
47 |
48 | (define-widget gallery (QScrollArea)
49 | ((location :initarg :location :accessor location)
50 | (thumbnails :accessor thumbnails)
51 | (current :initform -1 :accessor current))
52 | (:default-initargs :location (user-homedir-pathname)))
53 |
54 | (defmethod (setf location) :after (pathname (gallery gallery))
55 | (reload-images gallery))
56 |
57 | (defmethod (setf current) :around (num (gallery gallery))
58 | (with-slots-bound (gallery gallery)
59 | (when (and (/= current num)
60 | (< -1 num (length thumbnails)))
61 | (when (/= current -1)
62 | (setf (selected (elt thumbnails current)) NIL))
63 | (call-next-method)
64 | (let ((thumbnail (elt thumbnails current)))
65 | (setf (selected thumbnail) T)
66 | (setf (image *main*) (file thumbnail))
67 | (q+:ensure-widget-visible gallery thumbnail))))
68 | num)
69 |
70 | (defmethod (setf image) ((file pathname) (gallery gallery))
71 | (loop for i from 0
72 | for widget across (slot-value gallery 'thumbnails)
73 | do (when (equalp file (file widget))
74 | (setf (current gallery) i))))
75 |
76 | (defmethod (setf image) ((null null) (gallery gallery)))
77 |
78 | (define-subwidget (gallery scrollable) (q+:make-qwidget))
79 |
80 | (define-subwidget (gallery layout) (q+:make-qhboxlayout scrollable)
81 | (setf (q+:margin layout) 0)
82 | (setf (q+:spacing layout) 0))
83 |
84 | (defmacro keycase (key &body cases)
85 | (let ((k (gensym "KEY")))
86 | `(let ((,k ,key))
87 | (cond ,@(loop for case in cases
88 | collect `((= ,k ,(first case))
89 | ,@(rest case)))))))
90 |
91 | (define-override (gallery key-release-event) (ev)
92 | (flet ((setc (n) (setf (current gallery) n)))
93 | (keycase (q+:key ev)
94 | ((q+:qt.key_d)
95 | (setc (1+ (current gallery))))
96 | ((q+:qt.key_a)
97 | (setc (1- (current gallery))))
98 | ((q+:qt.key_right)
99 | (setc (1+ (current gallery))))
100 | ((q+:qt.key_left)
101 | (setc (1- (current gallery))))
102 | ((q+:qt.key_page-up)
103 | (setc (1- (length thumbnails))))
104 | ((q+:qt.key_page-down)
105 | (setc 0)))))
106 |
107 | (define-override (gallery resize-event) (ev)
108 | (cond ((and (< (+ 10 (q+:width gallery)) (q+:height gallery))
109 | (qtypep layout (find-qclass "QHBoxLayout")))
110 | (change-layout gallery :vertical))
111 | ((and (< (+ 10 (q+:height gallery)) (q+:width gallery))
112 | (qtypep layout (find-qclass "QVBoxLayout")))
113 | (change-layout gallery :horizontal)))
114 | (stop-overriding))
115 |
116 | (define-initializer (gallery setup)
117 | (setf (q+:background-role gallery) (q+:qpalette.background))
118 | (setf (q+:vertical-scroll-bar-policy gallery) (q+:qt.scroll-bar-always-off))
119 | (setf (q+:horizontal-scroll-bar-policy gallery) (q+:qt.scroll-bar-always-on))
120 | (setf (q+:widget-resizable gallery) NIL)
121 | (setf (q+:widget gallery) scrollable))
122 |
123 | (define-finalizer (gallery teardown)
124 | (do-layout (widget layout)
125 | (finalize widget)))
126 |
127 | (defun sort-files (files by &optional descending)
128 | (macrolet ((sorter (comp key)
129 | `(lambda (a b) (let ((result (,comp (,key a) (,key b))))
130 | (if descending (not result) result)))))
131 | (sort files (ecase by
132 | (:name (sorter string< pathname-name))
133 | (:time (sorter #.(or (find-symbol "STAMP<" "UIOP") (find-symbol "TIMESTAMP<" "UIOP")) uiop:safe-file-write-date))))))
134 |
135 | (defun directory-images (dir)
136 | (remove-if-not #'image-file-p (uiop:directory-files dir)))
137 |
138 | (defun reload-images (gallery)
139 | (let ((files (sort-files (directory-images (location gallery)) :time T)))
140 | (with-slots-bound (gallery gallery)
141 | (sweep-layout layout)
142 | (setf thumbnails (make-array 0 :adjustable T :fill-pointer 0))
143 | (setf current -1)
144 | (dolist (file files)
145 | (let ((thumb (make-instance 'thumbnail :file file)))
146 | (vector-push-extend thumb (thumbnails gallery))
147 | (q+:add-widget layout thumb)))
148 | (if (qtypep layout (find-qclass "QHBoxLayout"))
149 | (setf (q+:fixed-size scrollable) (values (* 128 (length (thumbnails gallery))) 128))
150 | (setf (q+:fixed-size scrollable) (values 128 (* 128 (length (thumbnails gallery))))))
151 | (setf (image *main*) (first files)))))
152 |
153 | (defun change-layout (gallery direction)
154 | (with-slots-bound (gallery gallery)
155 | (let* ((newwidget (q+:make-qwidget))
156 | (newlayout (ecase direction
157 | (:horizontal
158 | (setf (q+:vertical-scroll-bar-policy gallery) (q+:qt.scroll-bar-always-off))
159 | (setf (q+:horizontal-scroll-bar-policy gallery) (q+:qt.scroll-bar-always-on))
160 | (q+:make-qhboxlayout newwidget))
161 | (:vertical
162 | (setf (q+:vertical-scroll-bar-policy gallery) (q+:qt.scroll-bar-always-on))
163 | (setf (q+:horizontal-scroll-bar-policy gallery) (q+:qt.scroll-bar-always-off))
164 | (q+:make-qvboxlayout newwidget))))
165 | (oldwidget scrollable)
166 | (oldlayout layout))
167 | (setf (q+:margin newlayout) 0)
168 | (setf (q+:spacing newlayout) 0)
169 | (setf layout newlayout)
170 | (setf scrollable newwidget)
171 | (setf (q+:widget gallery) scrollable)
172 | (finalize oldlayout)
173 | (finalize oldwidget)
174 | (reload-images gallery))))
175 |
--------------------------------------------------------------------------------
/halftone.asd:
--------------------------------------------------------------------------------
1 | #|
2 | This file is a part of halftone
3 | (c) 2015 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
4 | Author: Nicolas Hafner
5 | |#
6 |
7 | (asdf:defsystem halftone
8 | :version "1.1.0"
9 | :license "zlib"
10 | :author "Nicolas Hafner "
11 | :maintainer "Nicolas Hafner "
12 | :description "An image viewer using Qtools"
13 | :homepage "https://Shinmera.github.io/halftone/"
14 | :bug-tracker "https://github.com/Shinmera/halftone/issues"
15 | :source-control (:git "https://github.com/Shinmera/halftone.git")
16 | :serial T
17 | :components ((:file "package")
18 | (:file "images")
19 | (:file "main")
20 | (:file "viewer")
21 | (:file "gallery"))
22 | :defsystem-depends-on (:qtools)
23 | :depends-on (:qtools
24 | :qtcore
25 | :qtgui
26 | :qtopengl
27 | :uiop
28 | :verbose
29 | :simple-tasks
30 | :bordeaux-threads)
31 | :build-operation "qt-program-op"
32 | :build-pathname "halftone"
33 | :entry-point "halftone:start")
34 |
--------------------------------------------------------------------------------
/images.lisp:
--------------------------------------------------------------------------------
1 | #|
2 | This file is a part of halftone
3 | (c) 2015 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
4 | Author: Nicolas Hafner
5 | |#
6 |
7 | (in-package #:org.shirakumo.halftone)
8 | (in-readtable :qtools)
9 |
10 | (defvar *image-loaders* (make-hash-table :test 'equalp))
11 |
12 | (defun image-loader (type)
13 | (gethash (string type) *image-loaders*))
14 |
15 | (defun (setf image-loader) (function type)
16 | (setf (gethash (string type) *image-loaders*) function))
17 |
18 | (defun remove-image-loader (type)
19 | (remhash (string type) *image-loaders*))
20 |
21 | (defmacro define-image-loader (types (pathname) &body body)
22 | (let ((types (if (listp types) types (list types)))
23 | (type (gensym "TYPE"))
24 | (func (gensym "FUNC")))
25 | `(let ((,func (lambda (,pathname) ,@body)))
26 | (dolist (,type ',types)
27 | (setf (image-loader ,type) ,func)))))
28 |
29 | (define-condition image-load-error (error)
30 | ((file :initarg :file :initform NIL :accessor file))
31 | (:report (lambda (c s) (format s "Failed to load image ~s" (file c)))))
32 |
33 | (defun image-file-p (pathname)
34 | (not (null (image-loader (pathname-type pathname)))))
35 |
36 | (defun load-image (pathname)
37 | (let ((loader (image-loader (pathname-type pathname))))
38 | (unless loader
39 | (error 'image-load-error :file pathname))
40 | (funcall loader pathname)))
41 |
42 | (defun load-thumbnail (pathname &optional (size 128))
43 | (let ((image (q+:make-qimage size size (q+:qimage.format_argb32_premultiplied))))
44 | (q+:fill image (q+:make-qcolor 0 0 0 0))
45 | (with-finalizing ((orig (load-image pathname)))
46 | (draw-image-fitting orig image))))
47 |
48 | (defvar *image-runner* (make-instance 'simple-tasks:queued-runner))
49 |
50 | (defclass image-loader-task (simple-tasks:task)
51 | ((file :initarg :file :accessor file)
52 | (callback :initarg :callback :accessor callback))
53 | (:default-initargs :file (error "FILE required.")))
54 |
55 | (defmethod print-object ((task image-loader-task) stream)
56 | (print-unreadable-object (task stream :type T)
57 | (format stream ":FILE ~s" (file task))))
58 |
59 | (defmethod simple-tasks:run-task ((task image-loader-task))
60 | (load-image (file task)))
61 |
62 | (defmethod simple-tasks:run-task :around ((task image-loader-task))
63 | (apply (callback task)
64 | (multiple-value-list (call-next-method))))
65 |
66 | (defclass thumbnail-loader-task (image-loader-task)
67 | ())
68 |
69 | (defmethod simple-tasks:run-task ((task thumbnail-loader-task))
70 | (load-thumbnail (file task)))
71 |
72 | (define-image-loader (:bmp :gif :jpg :jpeg :png :pbm :pgm :tiff :xbm :xpm) (pathname)
73 | (let ((image (q+:make-qimage)))
74 | (unless (q+:load image (uiop:native-namestring pathname))
75 | (finalize image)
76 | (error 'image-load-error :file pathname))
77 | image))
78 |
79 | (defun draw-image-fitting (image target)
80 | (with-finalizing ((painter (q+:make-qpainter target)))
81 | (setf (q+:render-hint painter) (values (q+:qpainter.antialiasing) T))
82 | (setf (q+:render-hint painter) (values (q+:qpainter.high-quality-antialiasing) T))
83 | (setf (q+:render-hint painter) (values (q+:qpainter.smooth-pixmap-transform) T))
84 | (let* ((width (q+:width image))
85 | (height (q+:height image))
86 | (aspect (/ width height)))
87 | (when (< (q+:width target) width)
88 | (setf width (q+:width target))
89 | (setf height (/ width aspect)))
90 | (when (< (q+:height target) height)
91 | (setf height (q+:height target))
92 | (setf width (* height aspect)))
93 | (let ((x (/ (- (q+:width target) width) 2))
94 | (y (/ (- (q+:height target) height) 2)))
95 | (q+:draw-image painter
96 | (q+:make-qrect (floor x) (floor y) (floor width) (floor height))
97 | image
98 | (q+:rect image)))))
99 | target)
100 |
101 | (defmacro with-callback-task ((task &rest targs) args &body body)
102 | `(simple-tasks:schedule-task (make-instance ',task ,@targs :callback (lambda ,args ,@body)) *image-runner*))
103 |
--------------------------------------------------------------------------------
/main.lisp:
--------------------------------------------------------------------------------
1 | #|
2 | This file is a part of halftone
3 | (c) 2015 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
4 | Author: Nicolas Hafner
5 | |#
6 |
7 | (in-package #:org.shirakumo.halftone)
8 | (in-readtable :qtools)
9 |
10 | (defvar *main*)
11 |
12 | (define-widget dock-container (QDockWidget)
13 | ((widget :initarg :widget :reader widget)
14 | (title :initarg :title :reader title))
15 | (:default-initargs
16 | :widget (error "WIDGET required.")
17 | :title ""))
18 |
19 | (define-initializer (dock-container setup)
20 | (setf (q+:widget dock-container) widget)
21 | (setf (q+:window-title dock-container) title)
22 | (setf (q+:features dock-container) (q+:qdockwidget.dock-widget-movable)))
23 |
24 | (define-widget main-window (QMainWindow)
25 | ())
26 |
27 | (define-initializer (main-window set-main 100)
28 | (setf *main* main-window)
29 | (setf (q+:window-title main-window) "Halftone")
30 | (q+:resize main-window 800 600))
31 |
32 | (define-subwidget (main-window viewer) (make-instance 'viewer)
33 | (setf (q+:central-widget main-window) viewer))
34 |
35 | (define-subwidget (main-window gallery) (make-instance 'gallery))
36 |
37 | (define-subwidget (main-window dockable) (make-instance 'dock-container :widget gallery :title "Gallery")
38 | (q+:add-dock-widget main-window (q+:qt.bottom-dock-widget-area) dockable))
39 |
40 | (defgeneric (setf image) (image thing)
41 | (:method (thing (main main-window))
42 | (with-slots-bound (main main-window)
43 | (setf (image viewer) thing)
44 | (setf (image gallery) thing))))
45 |
46 | (define-menu (main-window File)
47 | (:item ("Open" (ctrl o))
48 | (let ((dir (q+:qfiledialog-get-existing-directory main-window "Browse" (uiop:native-namestring (location gallery)))))
49 | (unless (or (qt:null-qobject-p dir) (string= dir ""))
50 | (setf (location gallery) (uiop:parse-native-namestring dir :ensure-directory T)))))
51 | (:separator)
52 | (:item ("Quit" (ctrl q))
53 | (q+:close main-window)))
54 |
55 | (define-menu (main-window Help)
56 | (:item "About"
57 | (let ((system (asdf:find-system :halftone)))
58 | (with-finalizing ((box (q+:make-qmessagebox main-window)))
59 | (setf (q+:window-title box) "About Halftone")
60 | (setf (q+:text box) (format NIL "~a
61 | The source code is openly available and licensed under ~a.
62 |
63 | Homepage: ~a
64 | Author: ~a
65 | Version: ~a"
66 | (asdf:system-description system)
67 | (asdf:system-license system)
68 | (asdf:system-homepage system)
69 | (asdf:system-author system)
70 | (asdf:component-version system)))
71 | (#_exec box)))))
72 |
73 | (defun main ()
74 | (unwind-protect
75 | (progn
76 | (bt:make-thread (lambda () (simple-tasks:start-runner *image-runner*)))
77 | (with-main-window (window 'main-window :name "Halftone")
78 | (with-slots-bound (window main-window)
79 | (setf (location gallery) (user-homedir-pathname)))))
80 | (simple-tasks:stop-runner *image-runner*)))
81 |
82 | (defun start ()
83 | #+:sbcl (sb-ext:disable-debugger)
84 | (setf v:*global-controller* (v:make-standard-global-controller))
85 | (let ((*main* NIL))
86 | (main)))
87 |
88 | (deploy:define-hook (:deploy stop-verbose) ()
89 | (v:remove-global-controller))
90 |
--------------------------------------------------------------------------------
/package.lisp:
--------------------------------------------------------------------------------
1 | #|
2 | This file is a part of halftone
3 | (c) 2015 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
4 | Author: Nicolas Hafner
5 | |#
6 |
7 | (in-package #:cl-user)
8 | (defpackage #:halftone
9 | (:nicknames #:org.shirakumo.halftone)
10 | (:use #:cl+qt)
11 | (:export
12 | #:main
13 | #:start))
14 |
--------------------------------------------------------------------------------
/viewer.lisp:
--------------------------------------------------------------------------------
1 | #|
2 | This file is a part of halftone
3 | (c) 2015 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
4 | Author: Nicolas Hafner
5 | |#
6 |
7 | (in-package #:org.shirakumo.halftone)
8 | (in-readtable :qtools)
9 |
10 | (define-widget viewer (QGLWidget)
11 | ((image :initarg :image :accessor image))
12 | (:default-initargs :image NIL))
13 |
14 | (defmethod (setf image) :before (thing (viewer viewer))
15 | (when (image viewer)
16 | (finalize (image viewer))
17 | (setf (slot-value viewer 'image) NIL)))
18 |
19 | (defmethod (setf image) ((file pathname) (viewer viewer))
20 | (with-callback-task (image-loader-task :file file) (result)
21 | (setf (image viewer) result)
22 | (signal! viewer (do-update))))
23 |
24 | (defmethod (setf image) ((null null) (viewer viewer))
25 | (signal! viewer (do-update)))
26 |
27 | (define-signal (viewer do-update) ())
28 |
29 | (define-initializer (viewer setup)
30 | (connect! viewer (do-update) viewer (update)))
31 |
32 | (define-override (viewer paint-event) (ev)
33 | (declare (ignore ev))
34 | (with-finalizing ((painter (q+:make-qpainter viewer)))
35 | (q+:erase-rect painter (q+:rect viewer)))
36 | (when (and image (not (qobject-deleted image)))
37 | (draw-image-fitting image viewer)))
38 |
--------------------------------------------------------------------------------