; 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 :notes-app (: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 :notes-app) ;(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 thread-signal ((sig target) bind callback) "Bind a signal handler: note that this intentionally shadows whatever the 'bind' argument is" `(g-signal-connect ,target ,(string-downcase (symbol-name sig)) ,callback)) (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))) (join-gtk-main))) ;(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))) (labels ((process-child (child box-sym) (if (listp child) (let* ((_initializers (if (< 2 (length child)) (cddr child) ())) (initializers (apply #'append _initializers)) (widget (second child))) (ecase (first child) (:start `(gtk-box-pack-start ,box-sym ,widget ,@initializers)) (:end `(gtk-box-pack-end ,box-sym ,widget ,@initializers))))))) (defmacro declare-box (initializers &body children) (let ((box-sym (gensym))) `(let ((,box-sym (make-instance 'gtk-box ,@initializers))) ,@(loop for child in children collect (process-child child box-sym)) ,box-sym)))) (defmacro declare-toolbar (initializers &body children) (let ((toolbar-sym (gensym))) `(let ((,toolbar-sym (gtk-toolbar-new))) ,@(loop for button in children collect `(gtk-toolbar-insert ,toolbar-sym (make-instance 'gtk-tool-button ,@button) -1)) ,toolbar-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))) (defun get-list-at-path (list-model path) (let* ((iter (gtk-tree-model-get-iter list-model path))) (selected (gtk-tree-model-get-value list-model iter 0))) ) (defvar *note-dir* "/home/edwlan/Dropbox/Notes/") (mainloop main window "test" 200 200 (let* (((:mval list-model list-view) (make-list-view (cl-fad:list-directory *note-dir*))) ((:mval text-buffer text-view) (make-text-view ""))) (on (row-activated list-view) (tree-view path column) (let* ((selected (get-list-at-path list-model path)) (file-contents (with-open-file (fd (merge-pathnames-as-file *note-dir* selected)) (let ((seq (make-string (file-length fd)))) (read-sequence seq fd) seq)))) (gtk-text-buffer-set-text text-buffer file-contents))) (gtk-container-add window (declare-paned-widget (:orientation :vertical) (declare-box (:orientation :vertical) (:end (declare-box (:orientation :horizontal) (:start (gtk-entry-new) (:fill t)) (:end (make-instance 'gtk-button :use-stock t :label "gtk-add") (:expand nil))) (:expand nil)) (:start (declare-scroll-window (:height-request 400) list-view) (:fill t))) (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))