; Copyright (c) 2014 Edward Langley ; All rights reserved. ; Redistribution and use in source and binary forms, with or without ; modification, are permitted provided that the following conditions ; are met: ; Redistributions of source code must retain the above copyright notice, ; this list of conditions and the following disclaimer. ; Redistributions in binary form must reproduce the above copyright ; notice, this list of conditions and the following disclaimer in the ; documentation and/or other materials provided with the distribution. ; Neither the name of the project's author nor the names of its ; contributors may be used to endorse or promote products derived from ; this software without specific prior written permission. ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED ; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (require 'asdf) (asdf:load-system 'quicklisp) (asdf:load-system :cl-cffi-gtk) (ql:quickload :cl-fad) (ql:quickload :x.let-star) (defpackage :gtk-tutorial (:use :gtk :gdk :gdk-pixbuf :gobject :glib :gio :pango :cairo :common-lisp :cl-fad :x.let-star) (:shadowing-import-from x.let-star let*) (:export main)) (in-package :gtk-tutorial) ;(macroexpand-1 '(on (clicked button) (__) ; (declare (ignore __)) ; (format t "Button 1 was pressed"))) (defmacro on ((sig target) bind &body body) "Bind a signal handler: note that this intentionally shadows whatever the 'bind' argument is" `(g-signal-connect ,target ,(string-downcase (symbol-name sig)) (lambda ,bind ,@body))) (defmacro mainloop (fname winvar title width height &body body) `(defun ,fname () (within-main-loop (let ((,winvar (make-instance 'gtk-window :title ,title :type :toplevel :default-width ,width :default-height ,height))) (on (destroy ,winvar) (widget) (declare (ignore widget)) (leave-gtk-main)) ,@body (gtk-widget-show-all ,winvar))))) ;(macroexpand-1 ; (quote ; (declare-paned-widget (:orientation :vertical) ; (declare-scroll-window () list-view) ; (declare-scroll-window (:wrap-mode :word) text-view)))) ;(let ((paned (make-instance 'gtk :orientation :vertical))) ; (let ((scroller (make-instance 'gtk-scroll-window))) ; (gtk-container-add list-view)) ; (let ((scroller (make-instance 'gtk-scroll-window :wrap-mode :word))) ; (gtk-container-add text-view))) (defmacro declare-scroll-window (initializers child) (let ((sw-sym (gensym))) `(let ((,sw-sym (make-instance 'gtk-scrolled-window ,@initializers))) (gtk-container-add ,sw-sym ,child) ,sw-sym))) (defmacro declare-paned-widget (initializers child1 child2) (let ((paned-sym (gensym))) `(let ((,paned-sym (make-instance 'gtk-paned ,@initializers))) (gtk-paned-add1 ,paned-sym ,child1) (gtk-paned-add2 ,paned-sym ,child2) ,paned-sym))) (defun make-list-view (display-list) (let ((store (make-instance 'gtk-list-store :column-types '("gchararray"))) (list-view (make-instance 'gtk-tree-view :headers-visible nil))) (gtk-tree-view-set-model list-view store) (loop for fn in display-list do (gtk-list-store-set store (gtk-list-store-append store) (file-namestring fn))) (let* ((renderer (make-instance 'gtk-cell-renderer-text)) (column (gtk-tree-view-column-new-with-attributes "Filename" renderer "text" 0))) (gtk-tree-view-append-column list-view column)) (values store list-view))) (defun make-text-view (text) (let* ((text-view (make-instance 'gtk-text-view :wrap-mode :word)) (buffer (gtk-text-view-get-buffer text-view))) (gtk-text-buffer-set-text buffer text) (values buffer text-view))) (defvar *note-directory* "/home/edwlan/Dropbox/Notes/") (mainloop main window "test" 200 200 (let* (((:mval list-model list-view) (make-list-view (cl-fad:list-directory *note-directory*))) ((:mval text-buffer text-view) (make-text-view ""))) (on (row-activated list-view) (tree-view path column) (let* ((iter (gtk-tree-model-get-iter list-model path)) (selected (gtk-tree-model-get-value list-model iter 0)) (file-contents (with-open-file (fd (merge-pathnames-as-file *note-directory* selected)) (let ((seq (make-string (file-length fd)))) (read-sequence seq fd) seq)))) (format t "~a ~a ~a~%" tree-view path column) (format t "~a~%" iter) (format t "~a~%" selected) (gtk-text-buffer-set-text text-buffer file-contents))) (gtk-container-add window (declare-paned-widget (:orientation :vertical) (declare-scroll-window (:height-request 400) list-view) (declare-scroll-window (:wrap-mode :word) text-view))))) ;(main) (labels ((slot-function (descriptor) (ecase descriptor (:start 'gtk-box-pack-start) (:end 'gtk-box-pack-end))) (proc-slot (box from-object slot) (if (equal (first slot) 'QUOTE) `(gtk-box-pack-start ,box (slot-value ,from-object ,slot)) (ecase (length slot) (1 `(gtk-box-pack-start ,box (slot-value ,from-object ,(first slot)))) (2 `(,(slot-function (second slot)) ,box (slot-value ,from-object ,(first slot)))))))) (defmacro renderwin (window box from-object &body slots) (let ((window-sym (gensym)) (box-sym (gensym)) (from-obj-sym (gensym))) `(let ((,window-sym ,window) (,box-sym ,box) (,from-obj-sym ,from-object)) ,@(loop for slot in slots collect (proc-slot box-sym from-obj-sym slot)) (gtk-container-add ,window-sym ,box-sym))))) (defclass mainwin nil ((file-view :initarg :file-view) (file-list :initarg :file-list))) (defun wrap-with-scrollwindow (widg &key (hscrpolicy :automatic) (vscrpolicy :automatic)) (let ((scroller (make-instance 'gtk-scrolled-window :hscrollbar-policy hscrpolicy :vscrollbar-policy vscrpolicy))) (gtk-container-add scroller widg) scroller))