Paste number 81072: a weekend with lambda-gtk

Paste number 81072: a weekend with lambda-gtk
Pasted by: fusss
When:8 months, 1 week ago
Share:Tweet this! | http://paste.lisp.org/+1QK0
Channel:#lisp
Paste contents:
Raw Source | XML | Display As
(gtk:define-signal-handler quit-signal :void (widget data)
  widget data
  (gtk:main-quit))

(gtk:define-signal-handler delete-signal :int (widget event data)
  widget event data
  (format t "delete-event ocurred~%")
  gtk:+false+)

(gtk:define-signal-handler motion-notify :int (widget event)
  widget event
  (gtk:window-set-position widget gtk:win-pos-mouse)
  (gtk:window-set-title widget (format nil  "(~a, ~a)" (gdk:eventmotion.x event) (gdk:eventmotion.y event)))
  (g:signal-emit-by-name widget "expose_event")
  (format t "motion-notify~%")
  (force-output)
  gtk:+false+)

(gtk:define-signal-handler button-clicked :void (widget data)
  (let* ((popup (gtk:window-new gtk:window-popup)))
    (gtk:container-add widget popup)))

;; (defgui button (gtk-button)
;;   (label
;;    callback
;;    parent))

;; (make-gui 'button :label "Hello World" :callback #'(lambda (gui data)
;; 						     (bar))
;; 	  :parent window) ==>
;; (make-gui class &args)


(defun foo ()
  (gtk:init-ensure)
  (gtk:rc-parse "theme/win32.gtkrc")
  (let* ((main-window (gtk:window-new gtk:window-toplevel))
	 (scroll (gtk:scrolled-window-new (g:nullptr) (g:nullptr)))
	 (viewport (gtk:viewport-new (gtk:scrolled-window-get-hadjustment scroll)
				     (gtk:scrolled-window-get-vadjustment scroll)))
	 (vbox (gtk:vbox-new gtk:+false+ 5)))
    (gtk:scrolled-window-set-policy scroll gtk:policy-automatic gtk:policy-automatic)
    (gtk:scrolled-window-add-with-viewport scroll vbox)
    (gtk:container-add main-window scroll)
    (dolist (pkg (list-all-packages))
      (gtk:box-pack-end vbox (gtk:button-new-with-label (package-name pkg))
			gtk:+true+ gtk:+true+ 0))
    (gtk:window-set-title main-window "Main Window")
    (gtk:window-set-default-size main-window 200 300)
   
    (gtk:window-set-position main-window gtk:win-pos-mouse)
    (gtk:widget-show-all main-window)
    (g:signal-connect main-window "motion_notify_event" (g:callback motion-notify) (g:nullptr))
    (g:signal-connect main-window "delete" (g:callback delete-signal) (g:nullptr))
    (g:signal-connect main-window "destroy" (g:callback quit-signal) (g:nullptr))
    (gtk:main)))

(foo)

(defun editor ()
  (gtk:init-ensure)
  (gtk:rc-parse "theme/win32.gtkrc")
  (let* ((main-window (gtk:window-new gtk:window-toplevel))
	 (vpaned (gtk:vpaned-new)))
    (gtk:paned-add1 vpaned (gtk:button-new-with-label "foo"))
    (gtk:paned-add2 vpaned (gtk:button-new-with-label "bar"))
    
    (gtk:window-set-title main-window "Main Window")
    (gtk:window-set-default-size main-window 200 300)
   
    (gtk:container-add main-window vpaned)
    (gtk:widget-show-all main-window)
;    (g:signal-connect button "clicked" (g:callback button-clicked) (g:nullptr))
    (g:signal-connect main-window "motion_notify_event" (g:callback motion-notify) (g:nullptr))
    (g:signal-connect main-window "delete" (g:callback delete-signal) (g:nullptr))
    (g:signal-connect main-window "destroy" (g:callback quit-signal) (g:nullptr))
    (gtk:main)))

(editor)

(gtk:define-signal-handler button-clicked :void (widget data)
  (let* ((popup (gtk:window-new gtk:window-popup)))
    (format t "button_press_event~%")
    (force-output))
  gtk:+false+)


; gtk:text-buffer-set-text


(defun main-window ()
  (let* ((main-window (gtk:window-new gtk:window-toplevel))
	 (vbox (gtk:vbox-new gtk:+false+ 0))
	 (notebook (gtk:notebook-new))
	 (url (gtk:label-new "cliki.net"))
	 (text-view (gtk:text-view-new))
	 (text-buffer (gtk:text-view-get-buffer text-view))
	 (scrolled-win (gtk:scrolled-window-new (g:nullptr) (g:nullptr)))
	 (menu-bar (gtk:menu-bar-new))
	 (tool-bar (gtk:toolbar-new))
	 (backward (gtk:button-new-from-stock "gtk-go-back"))
	 (forward (gtk:button-new-from-stock "gtk-go-forward"))
	 (file (gtk:menu-item-new-with-label "File"))
	 (edit (gtk:menu-item-new-with-label "Edit"))
	 (help (gtk:menu-item-new-with-label "Help"))
	 (file-menu (gtk:menu-new))
	 (edit-menu (gtk:menu-new))
	 (help-menu (gtk:menu-new))
	 (status-bar (gtk:statusbar-new))
	 (sb-context (gtk:statusbar-get-context-id status-bar "help"))
	 (event-box (gtk:event-box-new))
	 (label (gtk:label-new "double click me")))
  
    (gtk:widget-set-size-request main-window 600 400)
    (gtk:menu-item-set-submenu file file-menu)
    (gtk:menu-shell-append file-menu (gtk:image-menu-item-new-from-stock "gtk-new" (g:nullptr)))
    (gtk:menu-item-set-submenu edit edit-menu)
    (gtk:menu-item-set-submenu help help-menu)
    (gtk:menu-shell-append menu-bar file)
    (gtk:menu-shell-append menu-bar edit)
    (gtk:menu-shell-append menu-bar help)
    
    (gtk:toolbar-set-style tool-bar gtk:toolbar-both)
    (gtk::toolbar-insert tool-bar backward 0)
    (gtk:toolbar-insert tool-bar forward 1)
    
    (gtk:container-add main-window vbox)
    (gtk:widget-show vbox)
    
    
    (gtk:container-add scrolled-win text-view)
    (gtk:notebook-append-page notebook scrolled-win url)
    
    (gtk:box-pack-start vbox menu-bar gtk:+false+ gtk:+false+ 2)
    
    (gtk:box-pack-start vbox notebook gtk:+true+ gtk:+true+ 2)
    (gtk:box-pack-start vbox status-bar gtk:+false+ gtk:+true+ 2)
    
    (gtk:widget-show-all main-window)
    (g:signal-connect event-box "button_press_event" (g:callback button-clicked) label)
    (g:signal-connect main-window "delete" (g:callback delete-signal) (g:nullptr))
    (g:signal-connect main-window "destroy" (g:callback quit-signal) (g:nullptr))
    (gtk:main)))

(main-window)  
					;(main-window)



(let* ((main-dialog (gtk:dialog-new))
;       (handle-box (gtk:handle-box-new))
       (toolbar (gtk:toolbar-new))
       (text (gtk:entry-new))
       (icon (gtk:image-new-from-file "logo.xpm")))
  (gtk:toolbar-insert toolbar icon 0);;"Back" "Go Back" "Private"
				 ;; icon
;; 					;(gtk:image-new-from-stock "gtk-go-back"
;; 						;			gtk:icon-size-button)
;; 					      delete-signal
;; 					      (g:nullptr))))
  (gtk:window-set-title main-dialog "Dialog test")
  (gtk:widget-set-size-request main-dialog 600 300)
  
  (gtk:toolbar-insert toolbar text 0)
  (gtk:widget-show text)
  (gtk:widget-realize main-dialog)
  (gtk:toolbar-set-orientation toolbar gtk:orientation-horizontal)
  (gtk:toolbar-set-style toolbar gtk:toolbar-both)
  (gtk:container-add main-dialog toolbar)

  (let ((entry (gtk:entry-new)))
    (g:signal-connect main-dialog "delete" (g:callback delete-signal) (g:nullptr))
    (g:signal-connect main-dialog "destroy" (g:callback quit-signal) (g:nullptr))
    (gtk:widget-show toolbar)
    (gtk:widget-show-all main-dialog)
    (gtk:main)))



(defun daaqad-samee (magaca salaan)
  (let* ((main-dialog (gtk:window-new gtk:window-toplevel))
	 (button (gtk:button-new-with-label salaan)))
    (gtk:window-set-title main-dialog magaca)
    (gtk:widget-set-size-request main-dialog 600 300)
    (gtk:container-add main-dialog button)
    (g:signal-connect main-dialog "delete" (g:callback delete-signal) (g:nullptr))
    (g:signal-connect main-dialog "destroy" (g:callback quit-signal) (g:nullptr))
    (gtk:widget-show-all main-dialog)
    (gtk:main)))

  
(daaqad-samee "iska waran" "maxamad hebelow")




(defmethod contain ((layout row-layout))
  (contain-layout (gtk:vbox-new gtk:+false+ 0)
		  layout))

(defmethod contain ((layout column-layout))
  (contain-layout (gtk:hbox-new gtk:+false+ 0)
		  layout))
  
(defun layout-fill (layout)
  (if (layout-resizable-p layout)
      gtk:+true+))

(defun layout-expand (layout)
  gtk:+true+)

(defmethod append-child ((parent layout) child)
  (gtk:box-pack-end parent child))

(defun contain-layout (box layout)
  (gtk:init-ensure)
  (let ((main-window (gtk:window-new gtk:window-toplevel)))    
    (dolist (child (reparent-layouts box (layout-children layout)))
      (gtk:box-pack-end box child			
			(layout-fill layout)
			(layout-expand layout)
			(layout-spacing layout)))
    (gtk:container-add main-window box)
    (g:signal-connect main-window "delete" (g:callback delete-signal) (g:nullptr))
    (g:signal-connect main-window "destroy" (g:callback quit-signal) (g:nullptr))
    (gtk:widget-show-all main-window)
    (gtk:main)))


(contain (make-instance 'column-layout 
			:resizable-p t
			:children (list (gtk:button-new-with-label "Foo")
					(gtk:button-new-with-label "Bar"))))

(contain (make-instance 'row-layout 
			:resizable-p nil
			:children (list (gtk:button-new-with-label "Foo")
					(gtk:button-new-with-label "Bar"))))

(contain (make-instance 'row-layout 
			:children (list (gtk:button-new-with-label "Foo")
					(gtk:button-new-with-label "Bar"))
			))

(contain (make-instance 'column-layout 
			:children (list (gtk:button-new-with-label "Foo")
					(gtk:button-new-with-label "Bar"))
			:spacing 5
			))


(defmacro horizontally (&rest children)
  `(contain (make-instance 'column-layout
			   :children (list ,@children))))

(defmacro vertically (&rest children)
  `(contain (make-instance 'row-layout
			   :children (list ,@children))))

This paste has no annotations.

Colorize as:
Show Line Numbers

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.