Added current version
This commit is contained in:
commit
ce586f88ed
57
gtk-test.lisp
Normal file
57
gtk-test.lisp
Normal file
@ -0,0 +1,57 @@
|
||||
(ql:quickload "cl-cffi-gtk")
|
||||
|
||||
(defpackage :my-gtk-app
|
||||
(:use :gtk :gdk :gdk-pixbuf :gobject
|
||||
:glib :gio :pango :cairo :common-lisp))
|
||||
|
||||
(in-package :my-gtk-app)
|
||||
|
||||
(defun make-todo-item (task complete incomplete)
|
||||
(let ((row (make-instance 'gtk-list-box-row :selectable nil))
|
||||
(box (gtk-box-new :horizontal 6))
|
||||
(checkmark (gtk-check-button-new))
|
||||
(label (gtk-label-new task)))
|
||||
(g-signal-connect checkmark "toggled"
|
||||
(lambda (w)
|
||||
(if (gtk-toggle-button-active w)
|
||||
(gtk-widget-reparent row complete)
|
||||
(gtk-widget-reparent row incomplete))))
|
||||
(gtk-container-add box checkmark)
|
||||
(gtk-container-add box label)
|
||||
(gtk-container-add row box)
|
||||
(gtk-widget-show-all row)
|
||||
row))
|
||||
|
||||
(defmacro within-box (window orientation &body body)
|
||||
(let ((boxsym (gensym)))
|
||||
`(let ((,boxsym (gtk-box-new ,orientation 5)))
|
||||
,@(mapcar (lambda (x) (list 'gtk-box-pack-start boxsym x))
|
||||
body)
|
||||
(gtk-container-add ,window ,boxsym)
|
||||
,boxsym)))
|
||||
|
||||
(defun my-app ()
|
||||
(within-main-loop
|
||||
(let ((win (gtk-window-new :toplevel)))
|
||||
(g-signal-connect win "destroy" (lambda (widget) widget (leave-gtk-main)))
|
||||
(let ((completed (gtk-list-box-new))
|
||||
(todo (gtk-list-box-new))
|
||||
(add-button (gtk-button-new-with-label "Add"))
|
||||
(entry (gtk-entry-new)))
|
||||
(g-signal-connect add-button "clicked"
|
||||
(lambda (widget)
|
||||
(declare (ignore widget))
|
||||
(gtk-list-box-prepend todo
|
||||
(make-todo-item
|
||||
(gtk-entry-text entry)
|
||||
completed
|
||||
todo))
|
||||
(setf (gtk-entry-text entry) "")))
|
||||
(within-box win :vertical
|
||||
(gtk-label-new "Completed tasks:")
|
||||
completed
|
||||
(gtk-label-new "TODO:")
|
||||
todo
|
||||
entry
|
||||
add-button))
|
||||
(gtk-widget-show-all win))))
|
Loading…
x
Reference in New Issue
Block a user