Added current version
This commit is contained in:
		
							
								
								
									
										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))))
 | 
				
			||||||
		Reference in New Issue
	
	Block a user