├── LICENSE ├── README.org ├── adw.lisp ├── cl-gdk4.asd ├── cl-gtk4.adw.asd ├── cl-gtk4.asd ├── cl-gtk4.sourceview.asd ├── cl-gtk4.webkit.asd ├── examples ├── README.org ├── adw.lisp ├── example-ui-file.ui ├── gdk4-cairo.lisp ├── gdk4.lisp ├── gtk4.lisp ├── screenshots │ ├── adw-win.png │ ├── adw.png │ ├── gdk4-cairo.png │ ├── gtk4-fibonacci.png │ ├── gtk4-simple.png │ ├── menu.png │ ├── sourceview.png │ ├── string-list-view.png │ ├── text-view.png │ ├── ui-file.png │ └── webkit.png ├── sourceview.lisp └── webkit.lisp ├── gdk-pixbuf2.lisp ├── gdk4.lisp ├── gtk4.lisp ├── screenshots └── live-reload.gif ├── sourceview.lisp └── webkit.lisp /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: cl-gtk4 2 | [[https://docs.gtk.org/gtk4/gtk-logo.svg]] 3 | 4 | GTK4/Libadwaita/WebKit bindings for Common Lisp. 5 | * Requirement 6 | Before getting started, please ensure these libraries are available in your system: 7 | - GTK4 8 | - GObject Introspection 9 | - WebkitGTK (optional) 10 | - libadwaita (optional) 11 | Theoretically, the application built with ~cl-gtk4~ can run on most systems supported by GTK4 and most implementations that support CFFI callback (required by ~cl-gobject-introspection~). 12 | The [[file:examples/][examples]] are tested to run on following implementations: 13 | - SBCL 14 | - Microsoft Windows \\ 15 | [[file:examples/screenshots/adw-win.png]] 16 | - MacOS \\ 17 | See: [[https://ibb.co/7KZz3r2]] 18 | - GNU/Linux \\ 19 | See the screenshots in the [[examples][Examples]] section. 20 | - CCL 21 | - ECL 22 | - ABCL 23 | * Usage 24 | 1. Currently, ~cl-gtk4~ is available on [[https://ultralisp.org][Ultralisp]], so it can be downloaded via Quicklisp with Ultralisp installed as its distribution. 25 | To install ~cl-gtk4~ manually, you can clone this repository along with the following dependencies into the ~local-projects~ under your Quicklisp installation root: 26 | - [[https://github.com/bohonghuang/cl-gobject-introspection-wrapper][cl-gobject-introspection-wrapper]] 27 | - [[https://github.com/bohonghuang/cl-glib][cl-glib]] 28 | 2. Load the library with: 29 | - ~(ql:quickload :cl-gtk4)~ 30 | - ~(ql:quickload :cl-gtk4.adw)~ (if you need libadwaita) 31 | - ~(ql:quickload :cl-gtk4.webkit)~ (if you need WebkitGTK) 32 | 3. For GTK4 usage, please refer to [[https://docs.gtk.org/gtk4/][GTK API reference]] and check out the [[https://github.com/bohonghuang/cl-gobject-introspection-wrapper#conversion-rules][conversion rules]] for these APIs. 33 | ** Multi-threading 34 | Please note that GTK runs in a single thread and is NOT thread-safe, so all the UI-related operations must happen in GTK [[https://docs.gtk.org/glib/main-loop.html][main event loop]], 35 | which means you cannot write the code like this: 36 | 37 | #+BEGIN_SRC lisp 38 | (let ((label (make-label :str "0")) 39 | (count 0)) 40 | (bt:make-thread 41 | (lambda () 42 | (loop :repeat 5 43 | :do (setf (label-text label) (format nil "~A" (incf count))) 44 | (sleep 1))))) 45 | #+END_SRC 46 | 47 | GLib provides ~idle_add~ and ~timeout_add~ to add a function to execute in the main event loop, 48 | which is thread-safe so that it can be called in other threads. 49 | [[https://github.com/bohonghuang/cl-glib][cl-glib]] wraps ~idle_add~ and ~timeout_add~, and [[https://github.com/bohonghuang/cl-gtk4][cl-gtk4]] create restarts for the handler passed for them to be invoked safely, 50 | even when conditions are signaled. 51 | It also provides the API for convenience: 52 | - ~gtk:run-in-main-event-loop~ \\ 53 | Execute the body in GTK main event loop, in which we can access the UI safely: 54 | #+BEGIN_SRC lisp 55 | (let ((label (make-label :str "0")) 56 | (count 0)) 57 | (bt:make-thread 58 | (lambda () 59 | (loop :repeat 5 60 | :do (gtk:run-in-main-event-loop 61 | (setf (label-text label) (format nil "~A" (incf count)))) 62 | (sleep 1))))) ; Don't put this into `gtk:run-in-main-event-loop' 63 | #+END_SRC 64 | ** Interactive Programming 65 | *** Live Reload 66 | You can reload the application without closing the window constructed in ~define-main-window~ by recompiling the ~define-application~ macro in top-level (Simply stroke =C-c C-c= if using Slime/Sly in Emacs): 67 | 68 | [[file:screenshots/live-reload.gif]] 69 | *** Restarts 70 | The API in ~cl-gtk4~ handles almost all possible recoverable errors by providing restarts, by which you can recover the program or safely exit the GTK application when encountering an error. 71 | Additionally, you can interrupt and quit the GTK program by typing =C-c C-c= in Emacs(Slime/Sly)'s REPL. 72 | * Examples 73 | See the [[file:examples/][examples]] folder. 74 | * Deployment 75 | The [[file:examples/][examples]] are ready for being built into executable if the implementation supports ~:program-op~: 76 | #+BEGIN_SRC lisp 77 | (asdf:operate :program-op :cl-gtk4/example) 78 | #+END_SRC 79 | Then you could find the executable file under the ~examples~ folder. 80 | 81 | Note that: 82 | - On ECL, for unknown reason, the ~:entry-point~ of the ASDF system is ignored. 83 | This command should be used instead: 84 | #+BEGIN_SRC lisp 85 | (asdf:make-build :cl-gtk4/example :type :program :epilogue-code '(progn (uiop:symbol-call :gtk4.example :simple) (si:exit))) 86 | #+END_SRC 87 | - On Microsoft Windows, it's recommended to launch your application via [[https://www.dependencywalker.com/][Dependency Walker]], then the shared libraries used by your application would appear in it. 88 | You should copy all these ~.dll~ files into the folder where you place the executable file. If you are using MSYS2, the folder structure might be like this: 89 | 90 | #+BEGIN_EXAMPLE 91 | . 92 | ├── bin 93 | │   ├── gdbus.exe 94 | │   ├── libgio-2.0-0.dll 95 | │   ├── libgirepository-1.0-1.dll 96 | │   ├── libglib-2.0-0.dll 97 | │   ├── libgobject-2.0-0.dll 98 | │   ├── libgtk-4-1.dll 99 | │   ├── your_application.exe 100 | │   └── ... 101 | ├── lib 102 | │   ├── girepository-1.0 103 | │   ├── gtk-4.0 104 | │   └── ... 105 | └── share 106 | ├── icons 107 | └── ... 108 | #+END_EXAMPLE 109 | 110 | The folder ~lib/girepository-1.0~ is mandatory, without which your application won't work as expected. 111 | -------------------------------------------------------------------------------- /adw.lisp: -------------------------------------------------------------------------------- 1 | ;;;; adw.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (cl:defpackage adw 19 | (:use) 20 | (:export #:*ns*)) 21 | 22 | (cl:in-package #:adw) 23 | 24 | (cl:eval-when (:execute :compile-toplevel :load-toplevel) 25 | (cl:setf gir-wrapper:*quoted-name-alist* '(("t" . time)))) 26 | 27 | (gir-wrapper:define-gir-namespace "Adw") 28 | 29 | (cl:eval-when (:execute :compile-toplevel :load-toplevel) 30 | (cl:setf gir-wrapper:*quoted-name-alist* cl:nil)) 31 | -------------------------------------------------------------------------------- /cl-gdk4.asd: -------------------------------------------------------------------------------- 1 | #+sbcl 2 | (eval-when (:compile-toplevel :load-toplevel :execute) 3 | (sb-int:set-floating-point-modes :traps nil)) 4 | 5 | (defsystem cl-gdk4 6 | :version "1.0.0" 7 | :author "Bohong Huang <1281299809@qq.com>" 8 | :maintainer "Bohong Huang <1281299809@qq.com>" 9 | :license "LGPLv3" 10 | :description "GDK4 bindings for Common Lisp." 11 | :homepage "https://github.com/bohonghuang/cl-gtk4" 12 | :bug-tracker "https://github.com/bohonghuang/cl-gtk4/issues" 13 | :source-control (:git "https://github.com/bohonghuang/cl-gtk4.git") 14 | :serial t 15 | :components ((:file "gdk-pixbuf2") 16 | (:file "gdk4" :depends-on ("gdk-pixbuf2"))) 17 | :depends-on (#:cl-gobject-introspection-wrapper)) 18 | 19 | (uiop:register-image-restore-hook 20 | (lambda () 21 | (let* ((namespace "Gdk") 22 | (package (find-package (string-upcase namespace)))) 23 | (when package 24 | (setf (symbol-value (find-symbol "*NS*" package)) 25 | (uiop:symbol-call :gir :require-namespace namespace "4.0")))) 26 | (let* ((namespace "GdkPixbuf") 27 | (package (find-package '#:gdk-pixbuf2))) 28 | (when package 29 | (setf (symbol-value (find-symbol "*NS*" package)) 30 | (uiop:symbol-call :gir :require-namespace namespace "2.0")))))) 31 | 32 | (defsystem cl-gdk4/example 33 | :depends-on (#:asdf 34 | #:cl-gtk4 35 | #:cl-gdk4 36 | #:cl-cairo2) 37 | :build-operation program-op 38 | :build-pathname "cl-gdk4-example" 39 | :entry-point "gdk4.example:cairo-test" 40 | :pathname "examples/" 41 | :components ((:file "gdk4") 42 | (:file "gdk4-cairo" :depends-on ("gdk4")))) 43 | -------------------------------------------------------------------------------- /cl-gtk4.adw.asd: -------------------------------------------------------------------------------- 1 | (defsystem cl-gtk4.adw 2 | :version "1.0.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "LGPLv3" 6 | :description "Libadwaita bindings for Common Lisp." 7 | :homepage "https://github.com/bohonghuang/cl-gtk4" 8 | :bug-tracker "https://github.com/bohonghuang/cl-gtk4/issues" 9 | :source-control (:git "https://github.com/bohonghuang/cl-gtk4.git") 10 | :serial t 11 | :components ((:file "adw")) 12 | :depends-on (#:cl-gobject-introspection-wrapper #:cl-gtk4)) 13 | 14 | (uiop:register-image-restore-hook 15 | (lambda () 16 | (let* ((namespace "Adw") 17 | (package (find-package (string-upcase namespace)))) 18 | (when package 19 | (setf (symbol-value (find-symbol "*NS*" package)) 20 | (uiop:symbol-call :gir :require-namespace namespace)))))) 21 | 22 | (defsystem cl-gtk4.adw/example 23 | :depends-on (#:asdf 24 | #:cl-gtk4 25 | #:cl-gtk4.adw) 26 | :build-operation program-op 27 | :build-pathname "cl-gtk4-libadwaita-example" 28 | :entry-point "adw.example:main" 29 | :pathname "examples/" 30 | :components ((:file "adw"))) 31 | -------------------------------------------------------------------------------- /cl-gtk4.asd: -------------------------------------------------------------------------------- 1 | (defsystem cl-gtk4 2 | :version "1.0.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "LGPLv3" 6 | :description "GTK4 bindings for Common Lisp." 7 | :homepage "https://github.com/bohonghuang/cl-gtk4" 8 | :bug-tracker "https://github.com/bohonghuang/cl-gtk4/issues" 9 | :source-control (:git "https://github.com/bohonghuang/cl-gtk4.git") 10 | :serial t 11 | :components ((:file "gtk4")) 12 | :depends-on (#:uiop #:cl-gobject-introspection-wrapper #:cl-glib #:cl-gio #:cl-gobject)) 13 | 14 | ;; (uiop:register-image-dump-hook (lambda () (uiop:symbol-call :tg :gc :full t) (sleep 1.0))) 15 | 16 | (uiop:register-image-restore-hook 17 | (lambda () 18 | (let* ((namespace "Gtk") 19 | (package (find-package (string-upcase namespace)))) 20 | (when package 21 | (setf (symbol-value (find-symbol "*NS*" package)) 22 | (uiop:symbol-call :gir :require-namespace namespace "4.0")))))) 23 | 24 | (defsystem cl-gtk4/example 25 | :depends-on (#:asdf 26 | #:bordeaux-threads 27 | #:cl-glib 28 | #:cl-gtk4) 29 | :build-operation program-op 30 | :build-pathname "cl-gtk4-example" 31 | :entry-point "gtk4.example:simple-menu" 32 | :pathname "examples/" 33 | :components ((:file "gtk4"))) 34 | -------------------------------------------------------------------------------- /cl-gtk4.sourceview.asd: -------------------------------------------------------------------------------- 1 | (defsystem cl-gtk4.sourceview 2 | :version "1.0.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "LGPLv3" 6 | :description "GtkSourceView bindings for Common Lisp." 7 | :homepage "https://github.com/bohonghuang/cl-gtk4" 8 | :bug-tracker "https://github.com/bohonghuang/cl-gtk4/issues" 9 | :source-control (:git "https://github.com/bohonghuang/cl-gtk4.git") 10 | :serial t 11 | :components ((:file "sourceview")) 12 | :depends-on (#:cl-gobject-introspection-wrapper #:cl-gtk4)) 13 | 14 | (uiop:register-image-restore-hook 15 | (lambda () 16 | (let ((package (find-package :sourceview))) 17 | (when package 18 | (setf (symbol-value (find-symbol "*NS*" package)) 19 | (uiop:symbol-call :gir :require-namespace "GtkSource" "5")))))) 20 | 21 | (defsystem cl-gtk4.sourceview/example 22 | :depends-on (#:asdf 23 | #:cl-gtk4 24 | #:cl-gtk4.sourceview) 25 | :build-operation program-op 26 | :build-pathname "cl-gtk4-sourceview-example" 27 | :entry-point "sourceview.example:main" 28 | :pathname "examples/" 29 | :components ((:file "sourceview"))) 30 | -------------------------------------------------------------------------------- /cl-gtk4.webkit.asd: -------------------------------------------------------------------------------- 1 | (defsystem cl-gtk4.webkit 2 | :version "1.0.0" 3 | :author "Bohong Huang <1281299809@qq.com>" 4 | :maintainer "Bohong Huang <1281299809@qq.com>" 5 | :license "LGPLv3" 6 | :description "WebKitGTK bindings for Common Lisp." 7 | :homepage "https://github.com/bohonghuang/cl-gtk4" 8 | :bug-tracker "https://github.com/bohonghuang/cl-gtk4/issues" 9 | :source-control (:git "https://github.com/bohonghuang/cl-gtk4.git") 10 | :serial t 11 | :components ((:file "webkit")) 12 | :depends-on (#:cl-gobject-introspection-wrapper #:cl-gtk4)) 13 | 14 | (uiop:register-image-restore-hook 15 | (lambda () 16 | (let ((package (find-package :webkit))) 17 | (when package 18 | (setf (symbol-value (find-symbol "*NS*" package)) 19 | (uiop:symbol-call :gir :require-namespace "WebKit" "6.0")))))) 20 | 21 | (defsystem cl-gtk4.webkit/example 22 | :depends-on (#:asdf 23 | #:cl-gtk4 24 | #:cl-gtk4.webkit) 25 | :build-operation program-op 26 | :build-pathname "cl-gtk4-webkit-example" 27 | :entry-point "webkit.example:main" 28 | :pathname "examples/" 29 | :components ((:file "webkit"))) 30 | -------------------------------------------------------------------------------- /examples/README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Example Gallery 2 | * [[file:gtk4.lisp::24][Simple Counter]] 3 | [[file:screenshots/gtk4-simple.png]] 4 | 5 | #+BEGIN_SRC lisp 6 | (ql:quickload :cl-gtk4/example) 7 | (gtk4.example:simple-counter) 8 | #+END_SRC 9 | * [[file:gtk4.lisp::49][Fibonacci Calculator]] (Multi-threading) 10 | [[file:screenshots/gtk4-fibonacci.png]] 11 | 12 | #+BEGIN_SRC lisp 13 | (ql:quickload :cl-gtk4/example) 14 | (gtk4.example:fibonacci) 15 | #+END_SRC 16 | * [[file:gtk4.lisp::95][Simple Menu]] 17 | [[file:screenshots/menu.png]] 18 | 19 | #+BEGIN_SRC lisp 20 | (ql:quickload :cl-gtk4/example) 21 | (gtk4.example:simple-menu) 22 | #+END_SRC 23 | * [[file:gtk4.lisp::154][Simple Text View]] 24 | [[file:screenshots/text-view.png]] 25 | 26 | #+BEGIN_SRC lisp 27 | (ql:quickload :cl-gtk4/example) 28 | (gtk4.example:simple-text-view) 29 | #+END_SRC 30 | * [[file:gtk4.lisp::187][String List View]] 31 | [[file:screenshots/string-list-view.png]] 32 | 33 | #+BEGIN_SRC lisp 34 | (ql:quickload :cl-gtk4/example) 35 | (gtk4.example:string-list-view) 36 | #+END_SRC 37 | * [[file:gtk4.lisp::235][UI File]] 38 | [[file:screenshots/ui-file.png]] 39 | 40 | #+BEGIN_SRC lisp 41 | (ql:quickload :cl-gtk4/example) 42 | (gtk4.example:ui-file) 43 | #+END_SRC 44 | * [[file:gdk4-cairo.lisp][Pokéball Drawing Area]] ([[https://github.com/rpav/cl-cairo2][cl-cairo2]]) 45 | [[file:screenshots/gdk4-cairo.png]] 46 | 47 | #+BEGIN_SRC lisp 48 | (ql:quickload :cl-gdk4/example) 49 | (gdk4.example:cairo-test) 50 | #+END_SRC 51 | * [[file:adw.lisp][Simple Lisp REPL]] (Libadwaita) 52 | [[file:screenshots/adw.png]] 53 | 54 | #+BEGIN_SRC lisp 55 | (ql:quickload :cl-gtk4.adw/example) 56 | (adw.example:main) 57 | #+END_SRC 58 | * [[file:webkit.lisp][Simple Web Browser]] (WebKitGTK) 59 | [[file:screenshots/webkit.png]] 60 | 61 | #+BEGIN_SRC lisp 62 | (ql:quickload :cl-gtk4.webkit/example) 63 | (webkit.example:main) 64 | #+END_SRC 65 | * [[file:sourceview.lisp][Simple Code Viewer]] (GtkSourceView) 66 | [[file:screenshots/sourceview.png]] 67 | 68 | #+BEGIN_SRC lisp 69 | (ql:quickload :cl-gtk4.sourceview/example) 70 | (sourceview.example:main) 71 | #+END_SRC 72 | -------------------------------------------------------------------------------- /examples/adw.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/adw.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (defpackage adw.example 19 | (:use #:cl #:gtk4) 20 | (:export #:main)) 21 | 22 | (in-package #:adw.example) 23 | 24 | (define-application (:name simple-repl 25 | :id "org.bohonghuang.libadwaita-example.simple-repl") 26 | (define-main-window (window (adw:make-application-window :app *application*)) 27 | (let ((expression nil)) 28 | (widget-add-css-class window "devel") 29 | (setf (widget-size-request window) '(400 600)) 30 | (let ((box (make-box :orientation +orientation-vertical+ 31 | :spacing 0))) 32 | (setf (adw:window-content window) box) 33 | (let ((header-bar (adw:make-header-bar))) 34 | (setf (adw:header-bar-title-widget header-bar) 35 | (adw:make-window-title :title (lisp-implementation-type) 36 | :subtitle (lisp-implementation-version))) 37 | (box-append box header-bar)) 38 | (let ((carousel (adw:make-carousel))) 39 | (setf (widget-hexpand-p carousel) t 40 | (widget-vexpand-p carousel) t 41 | (adw:carousel-interactive-p carousel) t) 42 | (let ((page (adw:make-status-page))) 43 | (setf (widget-hexpand-p page) t 44 | (widget-vexpand-p page) t 45 | (adw:status-page-icon-name page) "utilities-terminal-symbolic" 46 | (adw:status-page-title page) "Simple Lisp REPL" 47 | (adw:status-page-description page) " ") 48 | (flet ((eval-expression (widget) 49 | (declare (ignore widget)) 50 | (when expression 51 | (setf (adw:status-page-description page) 52 | (princ-to-string 53 | (handler-case (eval expression) 54 | (error (err) err))))))) 55 | (let ((box (make-box :orientation +orientation-vertical+ 56 | :spacing 0))) 57 | (let ((group (adw:make-preferences-group))) 58 | (setf (widget-margin-all group) 10) 59 | (let ((row (adw:make-action-row))) 60 | (setf (adw:preferences-row-title row) (format nil "~A>" (or (car (package-nicknames *package*)) 61 | (package-name *package*)))) 62 | (let ((entry (make-entry))) 63 | (setf (widget-valign entry) +align-center+ 64 | (widget-hexpand-p entry) t) 65 | (connect entry "changed" (lambda (entry) 66 | (setf expression (ignore-errors (read-from-string (entry-buffer-text (entry-buffer entry))))) 67 | (funcall (if expression #'widget-remove-css-class #'widget-add-css-class) entry "error"))) 68 | (connect entry "activate" #'eval-expression) 69 | (adw:action-row-add-suffix row entry)) 70 | (adw:preferences-group-add group row)) 71 | (box-append box group)) 72 | (let ((carousel-box box) 73 | (box (make-box :orientation +orientation-horizontal+ 74 | :spacing 0))) 75 | (setf (widget-hexpand-p box) t 76 | (widget-halign box) +align-fill+) 77 | (let ((button (make-button :label "Exit"))) 78 | (setf (widget-css-classes button) '("pill") 79 | (widget-margin-all button) 10 80 | (widget-hexpand-p button) t) 81 | (connect button "clicked" (lambda (button) 82 | (declare (ignore button)) 83 | (window-destroy window))) 84 | (box-append box button)) 85 | (let ((button (make-button :label "Eval"))) 86 | (setf (widget-css-classes button) '("suggested-action" "pill") 87 | (widget-margin-all button) 10 88 | (widget-hexpand-p button) t) 89 | (connect button "clicked" #'eval-expression) 90 | (box-append box button)) 91 | (box-append carousel-box box)) 92 | (setf (adw:status-page-child page) box))) 93 | (adw:carousel-append carousel page)) 94 | (box-append box carousel))) 95 | (unless (widget-visible-p window) 96 | (window-present window))))) 97 | 98 | (defun main () 99 | (unless (adw:initialized-p) 100 | (adw:init)) 101 | (simple-repl)) 102 | -------------------------------------------------------------------------------- /examples/example-ui-file.ui: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | UI File Example 8 | 9 | 10 | vertical 11 | 12 | 13 | 50 14 | <i>Hello</i> <b>World</b>! 15 | True 16 | True 17 | 100 18 | 19 | 20 | 21 | 22 | Exit 23 | 24 | 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /examples/gdk4-cairo.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/gdk4-cairo.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (cl:defpackage cairo-gobject 19 | (:use) 20 | (:export #:*ns*)) 21 | 22 | (cl:in-package #:cairo-gobject) 23 | 24 | (gir-wrapper:define-gir-namespace "cairo") 25 | 26 | (cl:in-package #:gdk4.example) 27 | 28 | (cffi:defcstruct gdk-rgba 29 | (red :float) 30 | (green :float) 31 | (blue :float) 32 | (alpha :float)) 33 | 34 | (defmacro with-gdk-rgba ((pointer color) &body body) 35 | `(locally 36 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) 37 | (cffi:with-foreign-object (,pointer '(:struct gdk-rgba)) 38 | (let ((,pointer (make-instance 'gir::struct-instance 39 | :class (gir:nget gdk::*ns* "RGBA") 40 | :this ,pointer))) 41 | (gdk:rgba-parse ,pointer ,color) 42 | (locally 43 | #+sbcl (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note)) 44 | ,@body))))) 45 | 46 | (declaim (ftype (function (t t t t) t) draw-func)) 47 | 48 | (cffi:defcallback %draw-func :void ((area :pointer) 49 | (cr :pointer) 50 | (width :int) 51 | (height :int) 52 | (data :pointer)) 53 | (declare (ignore data)) 54 | (let ((cairo:*context* (make-instance 'cairo:context 55 | :pointer cr 56 | :width width 57 | :height height 58 | :pixel-based-p nil))) 59 | (draw-func (make-instance 'gir::object-instance 60 | :class (gir:nget gtk:*ns* "DrawingArea") 61 | :this area) 62 | (make-instance 'gir::struct-instance 63 | :class (gir:nget cairo-gobject:*ns* "Context") 64 | :this cr) 65 | width height))) 66 | 67 | (define-application (:name cairo-test 68 | :id "org.bohonghuang.gdk4-cairo-example") 69 | (defun draw-func (area cr width height) 70 | (declare (ignore area) 71 | (optimize (speed 3) 72 | (debug 0) 73 | (safety 0))) 74 | (let ((width (coerce (the fixnum width) 'single-float)) 75 | (height (coerce (the fixnum height) 'single-float)) 76 | (fpi (coerce pi 'single-float))) 77 | (let* ((radius (/ (min width height) 2.0)) 78 | (stroke-width (/ radius 8.0)) 79 | (button-radius (* radius 0.4))) 80 | (declare (type single-float radius stroke-width button-radius)) 81 | (with-gdk-rgba (color "#000000") 82 | (cairo:arc (/ width 2.0) (/ height 2.0) radius 0.0 (* 2.0 fpi)) 83 | (gdk:cairo-set-source-rgba cr color) 84 | (cairo:fill-path)) 85 | (with-gdk-rgba (color "#FF0000") 86 | (cairo:arc (/ width 2.0) (/ height 2.0) (- radius stroke-width) pi (* 2.0 fpi)) 87 | (gdk:cairo-set-source-rgba cr color) 88 | (cairo:fill-path)) 89 | (with-gdk-rgba (color "#FFFFFF") 90 | (cairo:arc (/ width 2.0) (/ height 2.0) (- radius stroke-width) 0.0 fpi) 91 | (gdk:cairo-set-source-rgba cr color) 92 | (cairo:fill-path)) 93 | (with-gdk-rgba (color "#000000") 94 | (let ((bar-length (sqrt (- (expt (* radius 2) 2.0) (expt stroke-width 2.0))))) 95 | (declare (type single-float bar-length)) 96 | (cairo:rectangle (+ (- (/ width 2.0) radius) (- radius (/ bar-length 2.0))) 97 | (+ (- (/ height 2.0) radius) (- radius (/ stroke-width 2.0))) 98 | bar-length 99 | stroke-width)) 100 | (gdk:cairo-set-source-rgba cr color) 101 | (cairo:fill-path)) 102 | (with-gdk-rgba (color "#000000") 103 | (cairo:arc (/ width 2.0) (/ height 2.0) button-radius 0.0 (* 2.0 fpi)) 104 | (gdk:cairo-set-source-rgba cr color) 105 | (cairo:fill-path)) 106 | (with-gdk-rgba (color "#FFFFFF") 107 | (cairo:arc (/ width 2.0) (/ height 2.0) (- button-radius stroke-width) 0.0 (* 2.0 fpi)) 108 | (gdk:cairo-set-source-rgba cr color) 109 | (cairo:fill-path))))) 110 | (define-main-window (window (make-application-window :application *application*)) 111 | (setf (window-title window) "Drawing Area Test") 112 | (let ((area (gtk:make-drawing-area))) 113 | (setf (drawing-area-content-width area) 200 114 | (drawing-area-content-height area) 200 115 | (drawing-area-draw-func area) (list (cffi:callback %draw-func) 116 | (cffi:null-pointer) 117 | (cffi:null-pointer))) 118 | (setf (window-child window) area)) 119 | (unless (widget-visible-p window) 120 | (window-present window)))) 121 | -------------------------------------------------------------------------------- /examples/gdk4.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/gdk4.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (cl:defpackage gdk4.example 19 | (:use #:cl #:gtk4) 20 | (:export #:cairo-test #:popover-test)) 21 | 22 | (cl:in-package #:gdk4.example) 23 | 24 | (define-application (:name popover-test 25 | :id "org.bohonghuang.gdk4-example.popover-test") 26 | (define-main-window (window (make-application-window :application *application*)) 27 | (setf (window-title window) "Popover Test") 28 | (let ((box (make-box :orientation +orientation-vertical+ :spacing 0))) 29 | (setf (widget-size-request box) '(200 200)) 30 | (let ((controller (make-gesture-click))) 31 | (connect controller 'pressed (lambda (self n-press x y) 32 | (declare (ignore self n-press)) 33 | (let ((popover (make-popover))) 34 | (box-append box popover) 35 | (cffi:with-foreign-object (rect '(:struct gdk4:rectangle)) 36 | (cffi:with-foreign-slots ((gdk::x gdk::y gdk::width gdk::height) rect (:struct gdk4:rectangle)) 37 | (setf gdk::x (round x) 38 | gdk::y (round y) 39 | gdk::width (round 0) 40 | gdk::height (round 0))) 41 | (setf (popover-child popover) (make-label :str "Popover") 42 | (popover-pointing-to popover) (gobj:pointer-object rect 'gdk:rectangle)) 43 | (popover-popup popover))))) 44 | (widget-add-controller box controller)) 45 | (let ((label (make-label :str "Click to pop up a Popover"))) 46 | (setf (widget-vexpand-p label) t) 47 | (box-append box label)) 48 | (setf (window-child window) box)) 49 | (unless (widget-visible-p window) 50 | (window-present window)))) 51 | -------------------------------------------------------------------------------- /examples/gtk4.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/gtk4.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (defpackage gtk4.example 19 | (:use #:cl #:gtk4) 20 | (:export #:simple-counter #:fibonacci #:simple-menu #:simple-text-view #:string-list-view #:ui-file)) 21 | 22 | (in-package #:gtk4.example) 23 | 24 | (define-application (:name simple-counter 25 | :id "org.bohonghuang.gtk4-example.simple-counter") 26 | (define-main-window (window (make-application-window :application *application*)) 27 | (setf (window-title window) "Simple Counter") 28 | (let ((box (make-box :orientation +orientation-vertical+ 29 | :spacing 4))) 30 | (let ((label (make-label :str "0"))) 31 | (setf (widget-hexpand-p label) t 32 | (widget-vexpand-p label) t) 33 | (box-append box label) 34 | (let ((button (make-button :label "Add")) 35 | (count 0)) 36 | (connect button "clicked" (lambda (button) 37 | (declare (ignore button)) 38 | (setf (label-text label) (format nil "~A" (incf count))))) 39 | (box-append box button)) 40 | (let ((button (make-button :label "Exit"))) 41 | (connect button "clicked" (lambda (button) 42 | (declare (ignore button)) 43 | (window-destroy window))) 44 | (box-append box button))) 45 | (setf (window-child window) box)) 46 | (unless (widget-visible-p window) 47 | (window-present window)))) 48 | 49 | (define-application (:name fibonacci 50 | :id "org.bohonghuang.gtk4-example.fibonacci") 51 | (defun fib (n) 52 | (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) 53 | (define-main-window (window (make-application-window :application *application*)) 54 | (let ((n 40)) 55 | (setf (window-title window) "Fibonacci Calculator") 56 | (let ((box (make-box :orientation +orientation-vertical+ 57 | :spacing 4))) 58 | (let ((label (make-label :str "0"))) 59 | (setf (widget-hexpand-p label) t 60 | (widget-vexpand-p label) t) 61 | (box-append box label) 62 | (let ((parent box) 63 | (box (make-box :orientation +orientation-horizontal+ 64 | :spacing 4))) 65 | (setf (widget-hexpand-p box) t 66 | (widget-halign box) +align-center+) 67 | (let ((label (make-label :str "n: "))) 68 | (box-append box label)) 69 | (let ((entry (make-entry))) 70 | (setf (widget-hexpand-p label) t 71 | (widget-halign label) +align-fill+ 72 | (entry-buffer-text (entry-buffer entry)) (format nil "~A" n)) 73 | (connect entry "changed" (lambda (entry) 74 | (setf n (ignore-errors (parse-integer (entry-buffer-text (entry-buffer entry))))))) 75 | (box-append box entry)) 76 | (box-append parent box)) 77 | (let ((button (make-button :label "Calculate"))) 78 | (connect button "clicked" (lambda (button) 79 | (bt:make-thread 80 | (lambda () 81 | (when n 82 | (run-in-main-event-loop () 83 | (setf (button-label button) "Calculating..." 84 | (widget-sensitive-p button) nil)) 85 | (let ((result (fib n))) 86 | (run-in-main-event-loop () 87 | (setf (label-text label) (format nil "~A" result) 88 | (button-label button) "Calculate" 89 | (widget-sensitive-p button) t)))))))) 90 | (box-append box button))) 91 | (setf (window-child window) box))) 92 | (unless (widget-visible-p window) 93 | (window-present window)))) 94 | 95 | (define-application (:name simple-menu 96 | :id "org.bohonghuang.gtk4-example.simple-menu") 97 | (defun simple-menu-menu () 98 | (let ((menu (gio:make-menu))) 99 | (let ((submenu (gio:make-menu))) 100 | (gio:menu-append-item submenu (gio:make-menu-item :model menu :label "Open" :detailed-action "app.open")) 101 | (gio:menu-append-item submenu (gio:make-menu-item :model menu :label "Exit" :detailed-action "app.exit")) 102 | (gio:menu-append-submenu menu "File" submenu)) 103 | (let ((submenu (gio:make-menu))) 104 | (gio:menu-append-item submenu (gio:make-menu-item :model menu :label "About" :detailed-action "app.about")) 105 | (gio:menu-append-submenu menu "Help" submenu)) 106 | (values menu))) 107 | (defun menu-test-about-dialog () 108 | (let ((dialog (make-about-dialog)) 109 | (system (asdf:find-system :cl-gtk4))) 110 | (setf (about-dialog-authors dialog) (list (asdf:system-author system)) 111 | (about-dialog-website dialog) (asdf:system-homepage system) 112 | (about-dialog-version dialog) (asdf:component-version system) 113 | (about-dialog-program-name dialog) (asdf:component-name system) 114 | (about-dialog-comments dialog) (asdf:system-description system) 115 | (about-dialog-logo-icon-name dialog) "application-x-addon") 116 | (values dialog))) 117 | (define-main-window (window (make-application-window :application *application*)) 118 | (setf (window-title window) "Simple Menu") 119 | (let ((header-bar (make-header-bar))) 120 | (let ((menu-button (make-menu-button))) 121 | (setf (menu-button-menu-model menu-button) (simple-menu-menu) 122 | (button-icon-name menu-button) "open-menu-symbolic") 123 | (header-bar-pack-end header-bar menu-button)) 124 | (setf (window-titlebar window) header-bar)) 125 | (let ((action (gio:make-simple-action :name "exit" 126 | :parameter-type nil))) 127 | (gio:action-map-add-action *application* action) 128 | (connect action "activate" 129 | (lambda (action param) 130 | (declare (ignore action param)) 131 | (gtk::destroy-all-windows-and-quit)))) 132 | (let ((action (gio:make-simple-action :name "about" 133 | :parameter-type nil))) 134 | (gio:action-map-add-action *application* action) 135 | (connect action "activate" 136 | (lambda (action param) 137 | (declare (ignore action param)) 138 | (let ((dialog (menu-test-about-dialog))) 139 | (setf (window-modal-p dialog) t 140 | (window-transient-for dialog) window) 141 | (window-present dialog))))) 142 | (let ((window-box (make-box :orientation +orientation-vertical+ 143 | :spacing 0))) 144 | (let ((menu-bar (make-popover-menu-bar :model (simple-menu-menu)))) 145 | (box-append window-box menu-bar)) 146 | (let ((empty-box (make-box :orientation +orientation-vertical+ 147 | :spacing 0))) 148 | (setf (widget-size-request empty-box) '(400 200)) 149 | (box-append window-box empty-box)) 150 | (setf (window-child window) window-box)) 151 | (unless (widget-visible-p window) 152 | (window-present window)))) 153 | 154 | (define-application (:name simple-text-view 155 | :id "org.bohonghuang.gtk4-example.simple-text-view") 156 | (define-main-window (window (make-application-window :application *application*)) 157 | (setf (window-title window) "Simple Text View") 158 | (let ((window-box (make-box :orientation +orientation-vertical+ 159 | :spacing 0))) 160 | (let ((body-box (make-box :orientation +orientation-vertical+ 161 | :spacing 0))) 162 | (let ((scrolled-window (make-scrolled-window))) 163 | (setf (widget-hexpand-p scrolled-window) t 164 | (widget-vexpand-p scrolled-window) t) 165 | (let ((view (make-text-view))) 166 | (setf (scrolled-window-child scrolled-window) view) 167 | (box-append body-box scrolled-window) 168 | (let ((buffer (text-view-buffer view))) 169 | (setf (text-buffer-text buffer) "Hello world!") 170 | (let ((button (make-button :label "Insert markup"))) 171 | (connect button "clicked" (lambda (button) 172 | (declare (ignore button)) 173 | (multiple-value-bind (has-selection-p start end) (text-buffer-selection-bounds buffer) 174 | (let ((pos (text-iter-offset start)) 175 | (text (if has-selection-p 176 | (prog1 (text-buffer-get-text buffer start end nil) 177 | (text-buffer-delete-selection buffer nil nil)) 178 | "Hello World!"))) 179 | (text-buffer-insert-markup buffer (text-buffer-get-iter-at-offset buffer pos) (format nil "~A" text)))))) 180 | (box-append body-box button))))) 181 | (setf (widget-size-request body-box) '(400 200)) 182 | (box-append window-box body-box)) 183 | (setf (window-child window) window-box)) 184 | (unless (widget-visible-p window) 185 | (window-present window)))) 186 | 187 | (define-application (:name string-list-view 188 | :id "org.bohonghuang.gtk4-example.string-list-view") 189 | (define-main-window (window (make-application-window :application *application*)) 190 | (let ((box (make-box :orientation +orientation-vertical+ :spacing 1))) 191 | (let* ((model (make-string-list :strings (loop :for i :from 1 :to 10 :collect (format nil "Item ~D" i)))) 192 | (factory (make-signal-list-item-factory)) 193 | (list-view (make-list-view :model (make-single-selection :model model) :factory factory))) 194 | (flet ((setup (factory item) 195 | (declare (ignore factory)) 196 | (setf (list-item-child item) (make-label :str ""))) 197 | (bind (factory item) 198 | (declare (ignore factory)) 199 | (setf (label-text (gobj:coerce (list-item-child item) 'label)) 200 | (string-object-string (gobj:coerce (list-item-item item) 'string-object)))) 201 | (unbind (factory item) 202 | (declare (ignore factory item))) 203 | (teardown (factory item) 204 | (declare (ignore factory item)))) 205 | (connect factory "setup" #'setup) 206 | (connect factory "bind" #'bind) 207 | (connect factory "unbind" #'unbind) 208 | (connect factory "teardown" #'teardown)) 209 | (let ((scrolled-window (make-scrolled-window))) 210 | (setf (widget-size-request scrolled-window) '(250 250) 211 | (widget-vexpand-p scrolled-window) t 212 | (widget-hexpand-p scrolled-window) t 213 | (scrolled-window-child scrolled-window) list-view) 214 | (box-append box scrolled-window)) 215 | (let ((button-append (make-button :label "Append")) 216 | (button-remove (make-button :label "Remove"))) 217 | (connect button-append "clicked" (lambda (button) 218 | (declare (ignore button)) 219 | (string-list-append model (format nil "Item ~D" (1+ (gio:list-model-n-items model)))))) 220 | (box-append box button-append) 221 | (connect button-remove "clicked" (lambda (button) 222 | (declare (ignore button)) 223 | (when (plusp (gio:list-model-n-items model)) 224 | (string-list-remove model (1- (gio:list-model-n-items model)))))) 225 | (box-append box button-remove))) 226 | (setf (window-title window) "String List View" 227 | (window-child window) box 228 | (window-default-size window) '(300 300))) 229 | (unless (widget-visible-p window) 230 | (window-present window)))) 231 | 232 | (defun system-absolute-pathname (pathname) 233 | (merge-pathnames pathname (asdf:component-pathname (asdf:find-system '#:cl-gtk4/example)))) 234 | 235 | (defun ui-file () 236 | (let ((app (make-application :application-id "org.bohonghuang.gtk4-example.ui-file" 237 | :flags gio:+application-flags-flags-none+))) 238 | (connect app "activate" 239 | (lambda (app) 240 | (let ((builder (gtk:make-builder))) 241 | (gtk:builder-add-from-file builder (namestring (system-absolute-pathname "example-ui-file.ui"))) 242 | (let ((window (gobj:coerce (builder-get-object builder "window") 'application-window)) 243 | (button (gobj:coerce (builder-get-object builder "button-exit") 'button))) 244 | (setf (window-application window) app) 245 | (connect button "clicked" (lambda (button) 246 | (declare (ignore button)) 247 | (window-destroy window))) 248 | (window-present window))))) 249 | (application-run app nil))) 250 | -------------------------------------------------------------------------------- /examples/screenshots/adw-win.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/adw-win.png -------------------------------------------------------------------------------- /examples/screenshots/adw.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/adw.png -------------------------------------------------------------------------------- /examples/screenshots/gdk4-cairo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/gdk4-cairo.png -------------------------------------------------------------------------------- /examples/screenshots/gtk4-fibonacci.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/gtk4-fibonacci.png -------------------------------------------------------------------------------- /examples/screenshots/gtk4-simple.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/gtk4-simple.png -------------------------------------------------------------------------------- /examples/screenshots/menu.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/menu.png -------------------------------------------------------------------------------- /examples/screenshots/sourceview.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/sourceview.png -------------------------------------------------------------------------------- /examples/screenshots/string-list-view.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/string-list-view.png -------------------------------------------------------------------------------- /examples/screenshots/text-view.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/text-view.png -------------------------------------------------------------------------------- /examples/screenshots/ui-file.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/ui-file.png -------------------------------------------------------------------------------- /examples/screenshots/webkit.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/examples/screenshots/webkit.png -------------------------------------------------------------------------------- /examples/sourceview.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/sourceview.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (defpackage gtksourceview.example 19 | (:use #:cl #:gtk4) 20 | (:nicknames sourceview.example) 21 | (:local-nicknames (#:sv #:sourceview)) 22 | (:export #:main)) 23 | 24 | (in-package #:sourceview.example) 25 | 26 | (defun system-absolute-pathname (pathname) 27 | (merge-pathnames pathname (asdf:component-pathname (asdf:find-system '#:cl-gtk4.sourceview/example)))) 28 | 29 | (define-application (:name main 30 | :id "org.bohonghuang.gtksourceview-example") 31 | (define-main-window (window (make-application-window :application *application*)) 32 | (setf (window-title window) "GtkSourceView Example") 33 | (let ((scrolled-window (make-scrolled-window))) 34 | (let ((buffer (sv:make-buffer :language (sv:language-manager-get-language 35 | (sv:make-language-manager) "commonlisp")))) 36 | (setf (gtk:text-buffer-text buffer) (alexandria:read-file-into-string 37 | (system-absolute-pathname "sourceview.lisp"))) 38 | (block setup-dark-scheme 39 | (let* ((manager (sv:make-style-scheme-manager)) 40 | (scheme (sv:style-scheme-manager-get-scheme 41 | manager (or (find-if 42 | (alexandria:curry #'search "Adwaita-dark") 43 | (sv:style-scheme-manager-scheme-ids manager)) 44 | (find-if 45 | (alexandria:curry #'search "dark") 46 | (sv:style-scheme-manager-scheme-ids manager)) 47 | (return-from setup-dark-scheme nil))))) 48 | (setf (sv:buffer-style-scheme buffer) scheme))) 49 | (let ((view (sv:make-view :buffer buffer))) 50 | (setf (sv:view-show-line-numbers-p view) t 51 | (sv:view-highlight-current-line-p view) t) 52 | (let ((provider (make-css-provider))) 53 | (css-provider-load-from-data provider "textview { font-family: Monospace; font-size: 12pt; }") 54 | (style-context-add-provider (widget-style-context view) provider +style-provider-priority-application+)) 55 | (setf (scrolled-window-child scrolled-window) view))) 56 | (setf (widget-size-request scrolled-window) '(1000 1000)) 57 | (setf (window-child window) scrolled-window)) 58 | (unless (widget-visible-p window) 59 | (window-present window)))) 60 | -------------------------------------------------------------------------------- /examples/webkit.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/webkit.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (defpackage webkit.example 19 | (:use #:cl #:gtk4) 20 | (:export #:main)) 21 | 22 | (in-package #:webkit.example) 23 | 24 | (defparameter *home-uri* "https://google.com") 25 | 26 | (define-application (:name main 27 | :id "org.bohonghuang.webkit-example") 28 | (define-main-window (window (make-application-window :application *application*)) 29 | (let ((web-view (webkit:make-web-view ))) 30 | (setf (window-title window) "CL-GTK4-WEBKIT-EXAMPLE" 31 | (window-default-size window) '(800 600)) 32 | (connect web-view "load-changed" (lambda (web-view event) 33 | (declare (ignore event)) 34 | (setf (window-title window) (if (webkit:web-view-loading-p web-view) 35 | (webkit:web-view-uri web-view) 36 | (webkit:web-view-title web-view))))) 37 | (let ((box (make-box :orientation +orientation-vertical+ 38 | :spacing 0))) 39 | (let ((toolbar (make-center-box))) 40 | (widget-add-css-class toolbar "toolbar") 41 | 42 | (let ((box (make-box :orientation +orientation-horizontal+ 43 | :spacing 4))) 44 | (let ((button (make-button :icon-name "go-previous-symbolic"))) 45 | (connect button "clicked" (lambda (button) 46 | (declare (ignore button)) 47 | (webkit:web-view-go-back web-view))) 48 | (connect web-view "load-changed" (lambda (web-view event) 49 | (declare (ignore event)) 50 | (setf (widget-sensitive-p button) (webkit:web-view-can-go-back-p web-view)))) 51 | (box-append box button)) 52 | (let ((button (make-button :icon-name "go-next-symbolic"))) 53 | (connect button "clicked" (lambda (button) 54 | (declare (ignore button)) 55 | (webkit:web-view-go-forward web-view))) 56 | (connect web-view "load-changed" (lambda (web-view event) 57 | (declare (ignore event)) 58 | (setf (widget-sensitive-p button) (webkit:web-view-can-go-forward-p web-view)))) 59 | (box-append box button)) 60 | (let ((button (make-button :icon-name "go-home-symbolic"))) 61 | (connect button "clicked" (lambda (button) 62 | (declare (ignore button)) 63 | (webkit:web-view-load-uri web-view *home-uri*))) 64 | (box-append box button)) 65 | (setf (center-box-start-widget toolbar) box)) 66 | (let ((box (make-box :orientation +orientation-horizontal+ 67 | :spacing 4))) 68 | (setf (widget-halign box) +align-fill+ 69 | (widget-hexpand-p box) t 70 | (widget-margin-start box) 50 71 | (widget-margin-end box) 50) 72 | (let ((entry (make-entry))) 73 | (setf (widget-halign entry) +align-fill+ 74 | (widget-hexpand-p entry) t) 75 | (connect entry "activate" (lambda (entry) 76 | (webkit:web-view-load-uri web-view (entry-buffer-text (entry-buffer entry))))) 77 | (connect web-view "load-changed" (lambda (web-view event) 78 | (declare (ignore event)) 79 | (setf (entry-buffer-text (entry-buffer entry)) (webkit:web-view-uri web-view)))) 80 | (box-append box entry)) 81 | (let ((button (make-button :icon-name "view-refresh-symbolic"))) 82 | (connect button "clicked" (lambda (button) 83 | (declare (ignore button)) 84 | (if (webkit:web-view-loading-p web-view) 85 | (webkit:web-view-stop-loading web-view) 86 | (webkit:web-view-reload web-view)))) 87 | (connect web-view "load-changed" (lambda (web-view event) 88 | (declare (ignore event)) 89 | (setf (button-icon-name button) (if (webkit:web-view-loading-p web-view) 90 | "process-stop-symbolic" 91 | "view-refresh-symbolic")))) 92 | (box-append box button)) 93 | (setf (center-box-center-widget toolbar) box)) 94 | (box-append box toolbar)) 95 | (let ((progress-bar (make-progress-bar))) 96 | (widget-add-css-class progress-bar "osd") 97 | (connect web-view "load-changed" (lambda (web-view event) 98 | (declare (ignore event)) 99 | (setf (progress-bar-fraction progress-bar) 100 | (if (webkit:web-view-loading-p web-view) 101 | (webkit:web-view-estimated-load-progress web-view) 102 | 0.0d0)))) 103 | (box-append box progress-bar)) 104 | (let ((web-view web-view)) 105 | (setf (widget-vexpand-p web-view) t 106 | (widget-hexpand-p web-view) t) 107 | (webkit:web-view-load-uri web-view *home-uri*) 108 | (box-append box web-view)) 109 | (setf (window-child window) box))) 110 | (unless (widget-visible-p window) 111 | (window-present window)))) 112 | -------------------------------------------------------------------------------- /gdk-pixbuf2.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage gdk-pixbuf2 2 | (:use) 3 | (:nicknames #:gdk-pixbuf) 4 | (:export #:*ns*)) 5 | 6 | (in-package #:gdk-pixbuf2) 7 | 8 | (gir-wrapper:define-gir-namespace "GdkPixbuf" "2.0") 9 | -------------------------------------------------------------------------------- /gdk4.lisp: -------------------------------------------------------------------------------- 1 | ;;;; gdk4.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (uiop:define-package gdk4 19 | (:use) 20 | (:use-reexport #:gdk-pixbuf2) 21 | (:shadow #:*ns*) 22 | (:nicknames #:gdk) 23 | (:export #:*ns*)) 24 | 25 | (cl:in-package #:gdk4) 26 | 27 | (cl:eval-when (:execute :compile-toplevel :load-toplevel) 28 | (cl:setf gir-wrapper:*quoted-name-alist* '(("KEY_a" . |+KEY-a+|) 29 | ("KEY_ae" . |+KEY-ae+|) 30 | ("KEY_aacute" . |+KEY-aacute+|) 31 | ("KEY_abelowdot" . |+KEY-abelowdot+|) 32 | ("KEY_abreve" . |+KEY-abreve+|) 33 | ("KEY_abreveacute" . |+KEY-abreveacute+|) 34 | ("KEY_abrevebelowdot" . |+KEY-abrevebelowdot+|) 35 | ("KEY_abrevegrave" . |+KEY-abrevegrave+|) 36 | ("KEY_abrevehook" . |+KEY-abrevehook+|) 37 | ("KEY_abrevetilde" . |+KEY-abrevetilde+|) 38 | ("KEY_acircumflex" . |+KEY-acircumflex+|) 39 | ("KEY_acircumflexacute" . |+KEY-acircumflexacute+|) 40 | ("KEY_acircumflexbelowdot" . |+KEY-acircumflexbelowdot+|) 41 | ("KEY_acircumflexgrave" . |+KEY-acircumflexgrave+|) 42 | ("KEY_acircumflexhook" . |+KEY-acircumflexhook+|) 43 | ("KEY_acircumflextilde" . |+KEY-acircumflextilde+|) 44 | ("KEY_adiaeresis" . |+KEY-adiaeresis+|) 45 | ("KEY_agrave" . |+KEY-agrave+|) 46 | ("KEY_ahook" . |+KEY-ahook+|) 47 | ("KEY_amacron" . |+KEY-amacron+|) 48 | ("KEY_aogonek" . |+KEY-aogonek+|) 49 | ("KEY_aring" . |+KEY-aring+|) 50 | ("KEY_Armenian_at" . |+KEY-ARMENIAN-at+|) 51 | ("KEY_Armenian_ayb" . |+KEY-ARMENIAN-ayb+|) 52 | ("KEY_Armenian_ben" . |+KEY-ARMENIAN-ben+|) 53 | ("KEY_Armenian_cha" . |+KEY-ARMENIAN-cha+|) 54 | ("KEY_Armenian_da" . |+KEY-ARMENIAN-da+|) 55 | ("KEY_Armenian_dza" . |+KEY-ARMENIAN-dza+|) 56 | ("KEY_Armenian_e" . |+KEY-ARMENIAN-e+|) 57 | ("KEY_Armenian_fe" . |+KEY-ARMENIAN-fe+|) 58 | ("KEY_Armenian_ghat" . |+KEY-ARMENIAN-ghat+|) 59 | ("KEY_Armenian_gim" . |+KEY-ARMENIAN-gim+|) 60 | ("KEY_Armenian_hi" . |+KEY-ARMENIAN-hi+|) 61 | ("KEY_Armenian_ho" . |+KEY-ARMENIAN-ho+|) 62 | ("KEY_Armenian_ini" . |+KEY-ARMENIAN-ini+|) 63 | ("KEY_Armenian_je" . |+KEY-ARMENIAN-je+|) 64 | ("KEY_Armenian_ke" . |+KEY-ARMENIAN-ke+|) 65 | ("KEY_Armenian_ken" . |+KEY-ARMENIAN-ken+|) 66 | ("KEY_Armenian_khe" . |+KEY-ARMENIAN-khe+|) 67 | ("KEY_Armenian_lyun" . |+KEY-ARMENIAN-lyun+|) 68 | ("KEY_Armenian_men" . |+KEY-ARMENIAN-men+|) 69 | ("KEY_Armenian_nu" . |+KEY-ARMENIAN-nu+|) 70 | ("KEY_Armenian_o" . |+KEY-ARMENIAN-o+|) 71 | ("KEY_Armenian_pe" . |+KEY-ARMENIAN-pe+|) 72 | ("KEY_Armenian_pyur" . |+KEY-ARMENIAN-pyur+|) 73 | ("KEY_Armenian_ra" . |+KEY-ARMENIAN-ra+|) 74 | ("KEY_Armenian_re" . |+KEY-ARMENIAN-re+|) 75 | ("KEY_Armenian_se" . |+KEY-ARMENIAN-se+|) 76 | ("KEY_Armenian_sha" . |+KEY-ARMENIAN-sha+|) 77 | ("KEY_Armenian_tche" . |+KEY-ARMENIAN-tche+|) 78 | ("KEY_Armenian_to" . |+KEY-ARMENIAN-to+|) 79 | ("KEY_Armenian_tsa" . |+KEY-ARMENIAN-tsa+|) 80 | ("KEY_Armenian_tso" . |+KEY-ARMENIAN-tso+|) 81 | ("KEY_Armenian_tyun" . |+KEY-ARMENIAN-tyun+|) 82 | ("KEY_Armenian_vev" . |+KEY-ARMENIAN-vev+|) 83 | ("KEY_Armenian_vo" . |+KEY-ARMENIAN-vo+|) 84 | ("KEY_Armenian_vyun" . |+KEY-ARMENIAN-vyun+|) 85 | ("KEY_Armenian_yech" . |+KEY-ARMENIAN-yech+|) 86 | ("KEY_Armenian_za" . |+KEY-ARMENIAN-za+|) 87 | ("KEY_Armenian_zhe" . |+KEY-ARMENIAN-zhe+|) 88 | ("KEY_atilde" . |+KEY-atilde+|) 89 | ("KEY_b" . |+KEY-b+|) 90 | ("KEY_babovedot" . |+KEY-babovedot+|) 91 | ("KEY_Byelorussian_shortu" . |+KEY-BYELORUSSIAN-shortu+|) 92 | ("KEY_c" . |+KEY-c+|) 93 | ("KEY_Ch" . |+KEY-Ch+|) 94 | ("KEY_ch" . |+KEY-ch+|) 95 | ("KEY_C_h" . |+KEY-C-h+|) 96 | ("KEY_c_h" . |+KEY-c-h+|) 97 | ("KEY_cabovedot" . |+KEY-cabovedot+|) 98 | ("KEY_cacute" . |+KEY-cacute+|) 99 | ("KEY_ccaron" . |+KEY-ccaron+|) 100 | ("KEY_ccedilla" . |+KEY-ccedilla+|) 101 | ("KEY_ccircumflex" . |+KEY-ccircumflex+|) 102 | ("KEY_ch" . |+KEY-ch+|) 103 | ("KEY_Cyrillic_a" . |+KEY-CYRILLIC-a+|) 104 | ("KEY_Cyrillic_be" . |+KEY-CYRILLIC-be+|) 105 | ("KEY_Cyrillic_che" . |+KEY-CYRILLIC-che+|) 106 | ("KEY_Cyrillic_che_descender" . |+KEY-CYRILLIC_che-DESCENDER+|) 107 | ("KEY_Cyrillic_che_vertstroke" . |+KEY-CYRILLIC_che-VERTSTROKE+|) 108 | ("KEY_Cyrillic_de" . |+KEY-CYRILLIC-de+|) 109 | ("KEY_Cyrillic_dzhe" . |+KEY-CYRILLIC-dzhe+|) 110 | ("KEY_Cyrillic_e" . |+KEY-CYRILLIC-e+|) 111 | ("KEY_Cyrillic_ef" . |+KEY-CYRILLIC-ef+|) 112 | ("KEY_Cyrillic_el" . |+KEY-CYRILLIC-el+|) 113 | ("KEY_Cyrillic_em" . |+KEY-CYRILLIC-em+|) 114 | ("KEY_Cyrillic_en" . |+KEY-CYRILLIC-en+|) 115 | ("KEY_Cyrillic_en_descender" . |+KEY-CYRILLIC_en-DESCENDER+|) 116 | ("KEY_Cyrillic_er" . |+KEY-CYRILLIC-er+|) 117 | ("KEY_Cyrillic_es" . |+KEY-CYRILLIC-es+|) 118 | ("KEY_Cyrillic_ghe" . |+KEY-CYRILLIC-ghe+|) 119 | ("KEY_Cyrillic_ghe_bar" . |+KEY-CYRILLIC_ghe-BAR+|) 120 | ("KEY_Cyrillic_ha" . |+KEY-CYRILLIC-ha+|) 121 | ("KEY_Cyrillic_hardsign" . |+KEY-CYRILLIC-hardsign+|) 122 | ("KEY_Cyrillic_ha_descender" . |+KEY-CYRILLIC_ha-DESCENDER+|) 123 | ("KEY_Cyrillic_i" . |+KEY-CYRILLIC-i+|) 124 | ("KEY_Cyrillic_ie" . |+KEY-CYRILLIC-ie+|) 125 | ("KEY_Cyrillic_io" . |+KEY-CYRILLIC-io+|) 126 | ("KEY_Cyrillic_i_macron" . |+KEY-CYRILLIC_i-MACRON+|) 127 | ("KEY_Cyrillic_je" . |+KEY-CYRILLIC-je+|) 128 | ("KEY_Cyrillic_ka" . |+KEY-CYRILLIC-ka+|) 129 | ("KEY_Cyrillic_ka_descender" . |+KEY-CYRILLIC-ka-DESCENDER+|) 130 | ("KEY_Cyrillic_ka_vertstroke" . |+KEY-CYRILLIC-ka-VERTSTROKE+|) 131 | ("KEY_Cyrillic_lje" . |+KEY-CYRILLIC-lje+|) 132 | ("KEY_Cyrillic_nje" . |+KEY-CYRILLIC-nje+|) 133 | ("KEY_Cyrillic_o" . |+KEY-CYRILLIC-o+|) 134 | ("KEY_Cyrillic_o_bar" . |+KEY-CYRILLIC_O-bar+|) 135 | ("KEY_Cyrillic_pe" . |+KEY-CYRILLIC-pe+|) 136 | ("KEY_Cyrillic_schwa" . |+KEY-CYRILLIC-schwa+|) 137 | ("KEY_Cyrillic_sha" . |+KEY-CYRILLIC-sha+|) 138 | ("KEY_Cyrillic_shcha" . |+KEY-CYRILLIC-shcha+|) 139 | ("KEY_Cyrillic_shha" . |+KEY-CYRILLIC-shha+|) 140 | ("KEY_Cyrillic_shorti" . |+KEY-CYRILLIC-shorti+|) 141 | ("KEY_Cyrillic_softsign" . |+KEY-CYRILLIC-softsign+|) 142 | ("KEY_Cyrillic_te" . |+KEY-CYRILLIC-te+|) 143 | ("KEY_Cyrillic_tse" . |+KEY-CYRILLIC-tse+|) 144 | ("KEY_Cyrillic_u" . |+KEY-CYRILLIC-u+|) 145 | ("KEY_Cyrillic_u_macron" . |+KEY-CYRILLIC-u-MACRON+|) 146 | ("KEY_Cyrillic_u_straight" . |+KEY-CYRILLIC-u-STRAIGHT+|) 147 | ("KEY_Cyrillic_u_straight_bar" . |+KEY-CYRILLIC-u-STRAIGHT-BAR+|) 148 | ("KEY_Cyrillic_ve" . |+KEY-CYRILLIC-ve+|) 149 | ("KEY_Cyrillic_ya" . |+KEY-CYRILLIC-ya+|) 150 | ("KEY_Cyrillic_yeru" . |+KEY-CYRILLIC-yeru+|) 151 | ("KEY_Cyrillic_yu" . |+KEY-CYRILLIC-yu+|) 152 | ("KEY_Cyrillic_ze" . |+KEY-CYRILLIC-ze+|) 153 | ("KEY_Cyrillic_zhe" . |+KEY-CYRILLIC-zhe+|) 154 | ("KEY_Cyrillic_zhe_descender" . |+KEY-CYRILLIC_ZHE-descender+|) 155 | ("KEY_d" . |+KEY-d+|) 156 | ("KEY_dabovedot" . |+KEY-dabovedot+|) 157 | ("KEY_dcaron" . |+KEY-dcaron+|) 158 | ("KEY_dstroke" . |+KEY-dstroke+|) 159 | ("KEY_e" . |+KEY-e+|) 160 | ("KEY_eng" . |+KEY-eng+|) 161 | ("KEY_eth" . |+KEY-eth+|) 162 | ("KEY_ezh" . |+KEY-ezh+|) 163 | ("KEY_eabovedot" . |+KEY-eabovedot+|) 164 | ("KEY_eacute" . |+KEY-eacute+|) 165 | ("KEY_ebelowdot" . |+KEY-ebelowdot+|) 166 | ("KEY_ecaron" . |+KEY-ecaron+|) 167 | ("KEY_ecircumflex" . |+KEY-ecircumflex+|) 168 | ("KEY_ecircumflexacute" . |+KEY-ecircumflexacute+|) 169 | ("KEY_ecircumflexbelowdot" . |+KEY-ecircumflexbelowdot+|) 170 | ("KEY_ecircumflexgrave" . |+KEY-ecircumflexgrave+|) 171 | ("KEY_ecircumflexhook" . |+KEY-ecircumflexhook+|) 172 | ("KEY_ecircumflextilde" . |+KEY-ecircumflextilde+|) 173 | ("KEY_ediaeresis" . |+KEY-ediaeresis+|) 174 | ("KEY_egrave" . |+KEY-egrave+|) 175 | ("KEY_ehook" . |+KEY-ehook+|) 176 | ("KEY_emacron" . |+KEY-emacron+|) 177 | ("KEY_eogonek" . |+KEY-eogonek+|) 178 | ("KEY_eth" . |+KEY-eth+|) 179 | ("KEY_etilde" . |+KEY-etilde+|) 180 | ("KEY_f" . |+KEY-f+|) 181 | ("KEY_fabovedot" . |+KEY-fabovedot+|) 182 | ("KEY_g" . |+KEY-g+|) 183 | ("KEY_gabovedot" . |+KEY-gabovedot+|) 184 | ("KEY_gbreve" . |+KEY-gbreve+|) 185 | ("KEY_gcaron" . |+KEY-gcaron+|) 186 | ("KEY_gcedilla" . |+KEY-gcedilla+|) 187 | ("KEY_gcircumflex" . |+KEY-gcircumflex+|) 188 | ("KEY_Greek_alpha" . |+KEY-GREEK-alpha+|) 189 | ("KEY_Greek_alphaaccent" . |+KEY-GREEK-alphaaccent+|) 190 | ("KEY_Greek_beta" . |+KEY-GREEK-beta+|) 191 | ("KEY_Greek_chi" . |+KEY-GREEK-chi+|) 192 | ("KEY_Greek_delta" . |+KEY-GREEK-delta+|) 193 | ("KEY_Greek_epsilon" . |+KEY-GREEK-epsilon+|) 194 | ("KEY_Greek_epsilonaccent" . |+KEY-GREEK-epsilonaccent+|) 195 | ("KEY_Greek_eta" . |+KEY-GREEK-eta+|) 196 | ("KEY_Greek_etaaccent" . |+KEY-GREEK-etaaccent+|) 197 | ("KEY_Greek_gamma" . |+KEY-GREEK-gamma+|) 198 | ("KEY_Greek_iota" . |+KEY-GREEK-iota+|) 199 | ("KEY_Greek_iotaaccent" . |+KEY-GREEK-iotaaccent+|) 200 | ("KEY_Greek_iotadieresis" . |+KEY-GREEK-iotadieresis+|) 201 | ("KEY_Greek_kappa" . |+KEY-GREEK-kappa+|) 202 | ("KEY_Greek_lambda" . |+KEY-GREEK-lambda+|) 203 | ("KEY_Greek_lamda" . |+KEY-GREEK-lamda+|) 204 | ("KEY_Greek_mu" . |+KEY-GREEK-mu+|) 205 | ("KEY_Greek_nu" . |+KEY-GREEK-nu+|) 206 | ("KEY_Greek_omega" . |+KEY-GREEK-omega+|) 207 | ("KEY_Greek_omegaaccent" . |+KEY-GREEK-omegaaccent+|) 208 | ("KEY_Greek_omicron" . |+KEY-GREEK-omicron+|) 209 | ("KEY_Greek_omicronaccent" . |+KEY-GREEK-omicronaccent+|) 210 | ("KEY_Greek_phi" . |+KEY-GREEK-phi+|) 211 | ("KEY_Greek_pi" . |+KEY-GREEK-pi+|) 212 | ("KEY_Greek_psi" . |+KEY-GREEK-psi+|) 213 | ("KEY_Greek_rho" . |+KEY-GREEK-rho+|) 214 | ("KEY_Greek_sigma" . |+KEY-GREEK-sigma+|) 215 | ("KEY_Greek_tau" . |+KEY-GREEK-tau+|) 216 | ("KEY_Greek_theta" . |+KEY-GREEK-theta+|) 217 | ("KEY_Greek_upsilon" . |+KEY-GREEK-upsilon+|) 218 | ("KEY_Greek_upsilonaccent" . |+KEY-GREEK-upsilonaccent+|) 219 | ("KEY_Greek_upsilondieresis" . |+KEY-GREEK-upsilondieresis+|) 220 | ("KEY_Greek_xi" . |+KEY-GREEK-xi+|) 221 | ("KEY_Greek_zeta" . |+KEY-GREEK-zeta+|) 222 | ("KEY_h" . |+KEY-h+|) 223 | ("KEY_hcircumflex" . |+KEY-hcircumflex+|) 224 | ("KEY_hstroke" . |+KEY-hstroke+|) 225 | ("KEY_i" . |+KEY-i+|) 226 | ("KEY_iacute" . |+KEY-iacute+|) 227 | ("KEY_ibelowdot" . |+KEY-ibelowdot+|) 228 | ("KEY_ibreve" . |+KEY-ibreve+|) 229 | ("KEY_icircumflex" . |+KEY-icircumflex+|) 230 | ("KEY_idiaeresis" . |+KEY-idiaeresis+|) 231 | ("KEY_igrave" . |+KEY-igrave+|) 232 | ("KEY_ihook" . |+KEY-ihook+|) 233 | ("KEY_imacron" . |+KEY-imacron+|) 234 | ("KEY_iogonek" . |+KEY-iogonek+|) 235 | ("KEY_itilde" . |+KEY-itilde+|) 236 | ("KEY_j" . |+KEY-j+|) 237 | ("KEY_jcircumflex" . |+KEY-jcircumflex+|) 238 | ("KEY_k" . |+KEY-k+|) 239 | ("KEY_kcedilla" . |+KEY-kcedilla+|) 240 | ("KEY_l" . |+KEY-l+|) 241 | ("KEY_lacute" . |+KEY-lacute+|) 242 | ("KEY_lbelowdot" . |+KEY-lbelowdot+|) 243 | ("KEY_lcaron" . |+KEY-lcaron+|) 244 | ("KEY_lcedilla" . |+KEY-lcedilla+|) 245 | ("KEY_lstroke" . |+KEY-lstroke+|) 246 | ("KEY_m" . |+KEY-m+|) 247 | ("KEY_mabovedot" . |+KEY-mabovedot+|) 248 | ("KEY_Macedonia_dse" . |+KEY-MACEDONIA-dse+|) 249 | ("KEY_Macedonia_gje" . |+KEY-MACEDONIA-gje+|) 250 | ("KEY_Macedonia_kje" . |+KEY-MACEDONIA-kje+|) 251 | ("KEY_n" . |+KEY-n+|) 252 | ("KEY_nacute" . |+KEY-nacute+|) 253 | ("KEY_ncaron" . |+KEY-ncaron+|) 254 | ("KEY_ncedilla" . |+KEY-ncedilla+|) 255 | ("KEY_ntilde" . |+KEY-ntilde+|) 256 | ("KEY_o" . |+KEY-o+|) 257 | ("KEY_oe" . |+KEY-oe+|) 258 | ("KEY_oacute" . |+KEY-oacute+|) 259 | ("KEY_obarred" . |+KEY-obarred+|) 260 | ("KEY_obelowdot" . |+KEY-obelowdot+|) 261 | ("KEY_ocaron" . |+KEY-ocaron+|) 262 | ("KEY_ocircumflex" . |+KEY-ocircumflex+|) 263 | ("KEY_ocircumflexacute" . |+KEY-ocircumflexacute+|) 264 | ("KEY_ocircumflexbelowdot" . |+KEY-ocircumflexbelowdot+|) 265 | ("KEY_ocircumflexgrave" . |+KEY-ocircumflexgrave+|) 266 | ("KEY_ocircumflexhook" . |+KEY-ocircumflexhook+|) 267 | ("KEY_ocircumflextilde" . |+KEY-ocircumflextilde+|) 268 | ("KEY_odiaeresis" . |+KEY-odiaeresis+|) 269 | ("KEY_odoubleacute" . |+KEY-odoubleacute+|) 270 | ("KEY_ograve" . |+KEY-ograve+|) 271 | ("KEY_ohook" . |+KEY-ohook+|) 272 | ("KEY_ohorn" . |+KEY-ohorn+|) 273 | ("KEY_ohornacute" . |+KEY-ohornacute+|) 274 | ("KEY_ohornbelowdot" . |+KEY-ohornbelowdot+|) 275 | ("KEY_ohorngrave" . |+KEY-ohorngrave+|) 276 | ("KEY_ohornhook" . |+KEY-ohornhook+|) 277 | ("KEY_ohorntilde" . |+KEY-ohorntilde+|) 278 | ("KEY_omacron" . |+KEY-omacron+|) 279 | ("KEY_ooblique" . |+KEY-ooblique+|) 280 | ("KEY_oslash" . |+KEY-oslash+|) 281 | ("KEY_otilde" . |+KEY-otilde+|) 282 | ("KEY_p" . |+KEY-p+|) 283 | ("KEY_pabovedot" . |+KEY-pabovedot+|) 284 | ("KEY_q" . |+KEY-q+|) 285 | ("KEY_r" . |+KEY-r+|) 286 | ("KEY_racute" . |+KEY-racute+|) 287 | ("KEY_rcaron" . |+KEY-rcaron+|) 288 | ("KEY_rcedilla" . |+KEY-rcedilla+|) 289 | ("KEY_s" . |+KEY-s+|) 290 | ("KEY_schwa" . |+KEY-schwa+|) 291 | ("KEY_sabovedot" . |+KEY-sabovedot+|) 292 | ("KEY_sacute" . |+KEY-sacute+|) 293 | ("KEY_scaron" . |+KEY-scaron+|) 294 | ("KEY_scedilla" . |+KEY-scedilla+|) 295 | ("KEY_scircumflex" . |+KEY-scircumflex+|) 296 | ("KEY_Serbian_dje" . |+KEY-SERBIAN-dje+|) 297 | ("KEY_Serbian_dze" . |+KEY-SERBIAN-dze+|) 298 | ("KEY_Serbian_je" . |+KEY-SERBIAN-je+|) 299 | ("KEY_Serbian_lje" . |+KEY-SERBIAN-lje+|) 300 | ("KEY_Serbian_nje" . |+KEY-SERBIAN-nje+|) 301 | ("KEY_Serbian_tshe" . |+KEY-SERBIAN-tshe+|) 302 | ("KEY_ScreenSaver" . |+KEY-screensaver+|) 303 | ("KEY_t" . |+KEY-t+|) 304 | ("KEY_thorn" . |+KEY-thorn+|) 305 | ("KEY_tabovedot" . |+KEY-tabovedot+|) 306 | ("KEY_tcaron" . |+KEY-tcaron+|) 307 | ("KEY_tcedilla" . |+KEY-tcedilla+|) 308 | ("KEY_thorn" . |+KEY-thorn+|) 309 | ("KEY_tslash" . |+KEY-tslash+|) 310 | ("KEY_u" . |+KEY-u+|) 311 | ("KEY_uacute" . |+KEY-uacute+|) 312 | ("KEY_ubelowdot" . |+KEY-ubelowdot+|) 313 | ("KEY_ubreve" . |+KEY-ubreve+|) 314 | ("KEY_ucircumflex" . |+KEY-ucircumflex+|) 315 | ("KEY_udiaeresis" . |+KEY-udiaeresis+|) 316 | ("KEY_udoubleacute" . |+KEY-udoubleacute+|) 317 | ("KEY_ugrave" . |+KEY-ugrave+|) 318 | ("KEY_uhook" . |+KEY-uhook+|) 319 | ("KEY_uhorn" . |+KEY-uhorn+|) 320 | ("KEY_uhornacute" . |+KEY-uhornacute+|) 321 | ("KEY_uhornbelowdot" . |+KEY-uhornbelowdot+|) 322 | ("KEY_uhorngrave" . |+KEY-uhorngrave+|) 323 | ("KEY_uhornhook" . |+KEY-uhornhook+|) 324 | ("KEY_uhorntilde" . |+KEY-uhorntilde+|) 325 | ("KEY_Ukrainian_ghe_with_upturn" . |+KEY-UKRAINIAN-ghe-WITH-UPTURN+|) 326 | ("KEY_Ukrainian_i" . |+KEY-UKRAINIAN-i+|) 327 | ("KEY_Ukrainian_ie" . |+KEY-UKRAINIAN-ie+|) 328 | ("KEY_Ukrainian_yi" . |+KEY-UKRAINIAN-yi+|) 329 | ("KEY_Ukranian_i" . |+KEY-UKRANIAN-i+|) 330 | ("KEY_Ukranian_je" . |+KEY-UKRANIAN-je+|) 331 | ("KEY_Ukranian_yi" . |+KEY-UKRANIAN-yi+|) 332 | ("KEY_umacron" . |+KEY-umacron+|) 333 | ("KEY_uogonek" . |+KEY-uogonek+|) 334 | ("KEY_uring" . |+KEY-uring+|) 335 | ("KEY_utilde" . |+KEY-utilde+|) 336 | ("KEY_v" . |+KEY-v+|) 337 | ("KEY_w" . |+KEY-w+|) 338 | ("KEY_wacute" . |+KEY-wacute+|) 339 | ("KEY_wcircumflex" . |+KEY-wcircumflex+|) 340 | ("KEY_wdiaeresis" . |+KEY-wdiaeresis+|) 341 | ("KEY_wgrave" . |+KEY-wgrave+|) 342 | ("KEY_x" . |+KEY-x+|) 343 | ("KEY_xabovedot" . |+KEY-xabovedot+|) 344 | ("KEY_y" . |+KEY-y+|) 345 | ("KEY_yacute" . |+KEY-yacute+|) 346 | ("KEY_ybelowdot" . |+KEY-ybelowdot+|) 347 | ("KEY_ycircumflex" . |+KEY-ycircumflex+|) 348 | ("KEY_ydiaeresis" . |+KEY-ydiaeresis+|) 349 | ("KEY_ygrave" . |+KEY-ygrave+|) 350 | ("KEY_yhook" . |+KEY-yhook+|) 351 | ("KEY_ytilde" . |+KEY-ytilde+|) 352 | ("KEY_z" . |+KEY-z+|) 353 | ("KEY_zabovedot" . |+KEY-zabovedot+|) 354 | ("KEY_zacute" . |+KEY-zacute+|) 355 | ("KEY_zcaron" . |+KEY-zcaron+|) 356 | ("KEY_zstroke" . |+KEY-zstroke+|) 357 | ("KEY_dead_a" . |+KEY-DEAD-a+|) 358 | ("KEY_dead_e" . |+KEY-DEAD-e+|) 359 | ("KEY_dead_i" . |+KEY-DEAD-i+|) 360 | ("KEY_dead_o" . |+KEY-DEAD-o+|) 361 | ("KEY_dead_u" . |+KEY-DEAD-u+|) 362 | ("KEY_dead_schwa" . |+KEY-DEAD-schwa+|) 363 | ("KEY_kana_a" . |+KEY-KANA-a+|) 364 | ("KEY_kana_e" . |+KEY-KANA-e+|) 365 | ("KEY_kana_i" . |+KEY-KANA-i+|) 366 | ("KEY_kana_o" . |+KEY-KANA-o+|) 367 | ("KEY_kana_tsu" . |+KEY-KANA-tsu+|) 368 | ("KEY_kana_tu" . |+KEY-KANA-tu+|) 369 | ("KEY_kana_u" . |+KEY-KANA-u+|) 370 | ("KEY_kana_ya" . |+KEY-KANA-ya+|) 371 | ("KEY_kana_yo" . |+KEY-KANA-yo+|) 372 | ("KEY_kana_yu" . |+KEY-KANA-yu+|)))) 373 | 374 | (gir-wrapper:define-gir-namespace "Gdk" "4.0") 375 | 376 | (cffi:defcstruct rectangle 377 | "A GdkRectangle data type for representing rectangles." 378 | (x :int) 379 | (y :int) 380 | (width :int) 381 | (height :int)) 382 | 383 | (cl:eval-when (:execute :compile-toplevel :load-toplevel) 384 | (cl:setf gir-wrapper:*quoted-name-alist* cl:nil)) 385 | -------------------------------------------------------------------------------- /gtk4.lisp: -------------------------------------------------------------------------------- 1 | ;;;; gtk4.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (defpackage gtk4 19 | (:use #:cl) 20 | (:nicknames #:gtk) 21 | (:import-from #:gio #:*application*) 22 | (:import-from #:gir #:property) 23 | (:export #:*ns* #:*application* #:property)) 24 | 25 | (in-package #:gtk4) 26 | 27 | (eval-when (:execute :compile-toplevel :load-toplevel) 28 | (setf gir-wrapper:*quoted-name-alist* '((("TextBuffer" . "get_insert") . text-buffer-get-insert) 29 | (("Gesture" . "group") . group-gestures) 30 | (("Widget" . "is_sensitive") . widget-is-sensitive-p) 31 | (("Widget" . "is_visible") . widget-is-visible-p) 32 | (("EntryBuffer" . "set_text")) 33 | (("TextBuffer" . "set_text"))))) 34 | 35 | (gir-wrapper:define-gir-namespace "Gtk" "4.0") 36 | 37 | (eval-when (:execute :compile-toplevel :load-toplevel) 38 | (setf gir-wrapper:*quoted-name-alist* nil)) 39 | 40 | (defun (setf entry-buffer-text) (value instance) 41 | (declare (type string value)) 42 | (gir:invoke (instance 'set-text) value -1)) 43 | 44 | (export 'entry-buffer-text) 45 | 46 | (defun text-buffer-text (instance) 47 | (gir:invoke (instance 'get-text) (text-buffer-start-iter instance) (text-buffer-end-iter instance) t)) 48 | 49 | (defun (setf text-buffer-text) (value instance) 50 | (declare (type string value)) 51 | (gir:invoke (instance 'set-text) value -1)) 52 | 53 | (export 'text-buffer-text) 54 | 55 | (defun (setf widget-margin-all) (value instance) 56 | (setf (widget-margin-top instance) value 57 | (widget-margin-bottom instance) value 58 | (widget-margin-start instance) value 59 | (widget-margin-end instance) value)) 60 | 61 | (export 'widget-margin-all) 62 | 63 | (defun destroy-all-windows () 64 | "Destroy all windows currently open in the application." 65 | (mapcar (alexandria:compose #'window-close (alexandria:rcurry #'gobj:pointer-object 'window)) 66 | (glib:glist-list (application-windows gio:*application*)))) 67 | 68 | (defun destroy-all-windows-and-quit () 69 | "Destroy all windows currently open in the application and exit the application." 70 | (destroy-all-windows) 71 | (idle-add (lambda () (gio:application-quit gio:*application*)))) 72 | 73 | (defun read-return-value () 74 | (format *query-io* "~&Enter the return value: ") 75 | (finish-output *query-io*) 76 | (multiple-value-list (eval (read *query-io*)))) 77 | 78 | (defun attach-restarts (function) 79 | "Return a wrapper function with restarts attached to FUNCTION." 80 | (lambda (&rest args) 81 | (with-condition-restarts (make-condition 'condition) (compute-restarts) 82 | (restart-case (apply function args) 83 | (return () 84 | :report "Return from current handler." 85 | (values nil)) 86 | (return-value (value) 87 | :report "Return from current handler with specified value." 88 | :interactive read-return-value 89 | (values value)) 90 | (abort () 91 | :report "Return from current handler and abort the GTK application." 92 | (destroy-all-windows-and-quit) 93 | (values nil)) 94 | (return-value-and-abort (value) 95 | :report "Return from current handler with specified value and abort the GTK application." 96 | :interactive read-return-value 97 | (destroy-all-windows-and-quit) 98 | (values value)))))) 99 | 100 | (defun connect (g-object signal c-handler &key after swapped) 101 | "Similar to GIR:CONNECT, but calls to C-HANDLER will attach restarts to 102 | safely exit the application in case of errors." 103 | (gir:connect g-object signal (attach-restarts c-handler) :after after :swapped swapped)) 104 | 105 | (export 'connect) 106 | 107 | (defun idle-add (function &optional (priority glib:+priority-default+)) 108 | "Similar to GLIB:IDLE-ADD, but calls to C-HANDLER will attach restarts 109 | to safely exit the application in case of errors." 110 | (glib:idle-add (attach-restarts function) priority)) 111 | 112 | (export 'idle-add) 113 | 114 | (defun timeout-add (interval function &optional (priority glib:+priority-default+)) 115 | "Similar to GLIB:TIMEOUT-ADD, but calls to C-HANDLER will attach 116 | restarts to safely exit the application in case of errors." 117 | (glib:timeout-add interval (attach-restarts function) priority)) 118 | 119 | (export 'timeout-add) 120 | 121 | (defun timeout-add-seconds (interval function &optional (priority glib:+priority-default+)) 122 | "Similar to GLIB:TIMEOUT-ADD-SECONDS, but calls to C-HANDLER will 123 | attach restarts to safely exit the application in case of errors." 124 | (glib:timeout-add-seconds interval (attach-restarts function) priority)) 125 | 126 | (export 'timeout-add-seconds) 127 | 128 | (defmacro run-in-main-event-loop ((&key (priority 'glib:+priority-default+)) &body body) 129 | "Execute BODY in the main event loop of the GTK application with PRIORITY." 130 | `(idle-add (lambda () ,@body nil) ,priority)) 131 | 132 | (export 'run-in-main-event-loop) 133 | 134 | (setf (fdefinition 'application-run) (fdefinition 'gio:application-run)) 135 | 136 | (export 'application-run) 137 | 138 | (defun simple-break-symbol () 139 | (find-symbol "SIMPLE-BREAK" (cond 140 | ((member :slynk *features*) :slynk) 141 | ((member :swank *features*) :swank) 142 | (t (return-from simple-break-symbol nil))))) 143 | 144 | (defvar *simple-break-function* nil) 145 | 146 | (defun break-from-main-event-loop () 147 | "A custom BREAK function to break the GTK event loop and safely exit 148 | the GTK application." 149 | (if gio:*application* 150 | (glib:idle-add (lambda () 151 | (with-condition-restarts (make-condition 'condition) (compute-restarts) 152 | (restart-case (funcall *simple-break-function*) 153 | (abort () 154 | :report "Abort the GTK application." 155 | (destroy-all-windows-and-quit)))) 156 | (values nil)) 157 | glib:+priority-high+) 158 | (funcall *simple-break-function*))) 159 | 160 | (defun install-break-handler () 161 | "Install the custom BREAK function as the break handler." 162 | (when *simple-break-function* 163 | (error "Cannot install the break handler twice.")) 164 | (setf *simple-break-function* (fdefinition (simple-break-symbol)) 165 | (fdefinition (simple-break-symbol)) (fdefinition 'break-from-main-event-loop))) 166 | 167 | (export 'install-break-handler) 168 | 169 | (defun uninstall-break-handler () 170 | "Uninstall the custom BREAK function as the break handler." 171 | (unless *simple-break-function* 172 | (error "The break handler has not been installed.")) 173 | (setf (fdefinition (simple-break-symbol)) *simple-break-function* 174 | *simple-break-function* nil)) 175 | 176 | (export 'uninstall-break-handler) 177 | 178 | (when (simple-break-symbol) 179 | (unless *simple-break-function* 180 | (install-break-handler))) 181 | 182 | (defmacro define-main-window (binding &body body) 183 | "Bind the window created based on BINDING to a variable and make it the 184 | main window of the application. This window automatically runs during 185 | the execution of the application and is updated automatically with the 186 | compilation of DEFINE-APPLICATION form. This macro can only be used 187 | within the DEFINE-APPLICATION macro, otherwise an error will be 188 | signaled during expansion." 189 | (declare (ignore binding body)) 190 | (error "Cannot expand DEFINE-MAIN-WINDOW outside DEFINE-APPLICATION.")) 191 | 192 | (defmacro define-application ((&key 193 | (id "org.bohonghunag.cl-gtk4" id-specified-p) 194 | (flags gio:+application-flags-flags-none+) 195 | (name nil)) 196 | &body 197 | body) 198 | "Define the entry function NAME for the application, in which an 199 | application object is created using ID and the application flags 200 | FLAGS. In the BODY, variables and functions related to the application 201 | can be defined, so that they can be compiled simultaneously when 202 | compiling this toplevel form. Typically, DEFINE-MAIN-WINDOW is used in 203 | the BODY to define the main window, which enables interactive 204 | hot-reloading during compilation." 205 | (let ((prefix (if id-specified-p (format nil "~A." id) ""))) 206 | (let ((window (intern (format nil "*~AMAIN-WINDOW*" (string-upcase prefix)))) 207 | (content (intern (format nil "~AMAIN-WINDOW-CONTENT" (string-upcase prefix)))) 208 | (main (intern (format nil "~AMAIN" (string-upcase prefix))))) 209 | `(macrolet ((define-main-window (binding &body body) 210 | (destructuring-bind (win-bind win-form) 211 | (etypecase binding 212 | (list binding) 213 | (symbol (list (gensym) binding))) 214 | `(progn 215 | (defun ,',content (,win-bind) 216 | (declare (ignorable ,win-bind)) 217 | ,@body) 218 | (defun ,',main (&optional argv) 219 | (let ((app (make-application :application-id ,',id 220 | :flags ,',flags))) 221 | (connect app "activate" (lambda (app) 222 | (declare (ignore app)) 223 | (let ((win (setf ,',window ,win-form))) 224 | (,',content win) 225 | (connect win "destroy" (lambda (win) (declare (ignore win)) (setf ,',window nil)))))) 226 | (application-run app argv))) 227 | ,(when ',name 228 | `(setf (fdefinition ',',name) (fdefinition ',',main))) 229 | (eval-when (:load-toplevel) 230 | (when ,',window 231 | (idle-add (lambda () (,',content ,',window) nil)))))))) 232 | 233 | (defvar ,window nil) 234 | ,@body)))) 235 | 236 | (export '(define-application define-main-window)) 237 | -------------------------------------------------------------------------------- /screenshots/live-reload.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bohonghuang/cl-gtk4/b3e69daf2f96e69881b053046bbe8544a54e087f/screenshots/live-reload.gif -------------------------------------------------------------------------------- /sourceview.lisp: -------------------------------------------------------------------------------- 1 | ;;;; sourceview.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (cl:defpackage gtksourceview 19 | (:use) 20 | (:nicknames #:sourceview) 21 | (:export #:*ns*)) 22 | 23 | (in-package #:sourceview) 24 | 25 | (gir-wrapper:define-gir-namespace "GtkSource" "5") 26 | -------------------------------------------------------------------------------- /webkit.lisp: -------------------------------------------------------------------------------- 1 | ;;;; webkit.lisp 2 | 3 | ;;;; Copyright (C) 2022-2023 Bohong Huang 4 | ;;;; 5 | ;;;; This program is free software: you can redistribute it and/or modify 6 | ;;;; it under the terms of the GNU Lesser General Public License as published by 7 | ;;;; the Free Software Foundation, either version 3 of the License, or 8 | ;;;; (at your option) any later version. 9 | ;;;; 10 | ;;;; This program is distributed in the hope that it will be useful, 11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | ;;;; GNU Lesser General Public License for more details. 14 | ;;;; 15 | ;;;; You should have received a copy of the GNU Lesser General Public License 16 | ;;;; along with this program. If not, see . 17 | 18 | (cl:defpackage webkit 19 | (:use) 20 | (:nicknames #:webkit) 21 | (:export #:*ns*)) 22 | 23 | (cl:in-package #:webkit) 24 | 25 | (gir-wrapper:define-gir-namespace "WebKit" "6.0") 26 | --------------------------------------------------------------------------------