@@ -0,0 +1,3 @@

+This is a fairly simple notebook application inspired by nvAlt.

+I'm primarily writing it as an exercise in Common Lisp, but I'm

+hoping that it'll be useful as well.

@@ -0,0 +1,3 @@

+- Implement saving after changes

+

+- Markdown highlighting

@@ -27,12 +27,19 @@

 ;  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))

+        :glib :gio :pango :cairo :common-lisp

+        :cl-fad :x.let-star)

+  (:shadowing-import-from x.let-star let*)

+  (:export main))

 (in-package :gtk-tutorial)

@@ -46,85 +53,129 @@

                      (lambda ,bind

                        ,@body)))

-(let ((surface nil))

-  (defun example-drawing ()

-    (within-main-loop

-      (let ((window (make-instance 'gtk-window

-                                   :type :toplevel

-                                   :title "Example Drawing"))

-            (frame (make-instance 'gtk-frame

-                                  :shadow-type :in))

-            (area (make-instance 'gtk-drawing-area

-                                 :width-request 250

-                                 :height-request 200)))

-

-        (on (destroy window) (__)

-          (declare (ignore __))

-          (leave-gtk-main))

-

-        (on (draw area) (widget cr)

-          (declare (ignore widget))

-          (let ((cr (pointer cr)))

-            (cairo-set-source-surface cr surface 0.0 0.0)

-            (cairo-paint cr)

-            (cairo-destroy cr)

-            +gdk-event-propagate+))

-

-        (on (configure-event area) (widget event)

-          (declare (ignore widget))

-          (when surface

-            (format t "surface is not nil~%")

-            (cairo-surface-destroy surface))

-          (setf surface (gdk-window-create-similar-surface

-                          (gtk-widget-window widget)

-                          :color

-                          (gtk-widget-get-allocated-width widget)

-                          (gtk-widget-get-allocated-height widget)))

-          (let ((cr (cairo-create surface)))

-            (cairo-set-source-rgb cr 1.0 1.0 1.0)

-            (cairo-paint cr)

-            (cairo-destroy cr)))

-

-        (on (motion-notify-event area) (widget event)

-          (format t "MOTION-NOTIFY-EVENT")

-          (when (member :button1-mask (gdk-event-motion-state event))

-            (let ((cr (cairo-create surface))

-                  (x (gdk-event-motion-x event))

-                  (y (gdk-event-motion-y event)))

-              (cairo-rectangle cr (- x 3.0) (- y 3.0) 6.0 6.0)

-              (cairo-fill cr)

-              (cairo-destroy cr)

-              (gtk-widget-queue-draw-area widget

-                                          (truncate (- x 3.0))

-                                          (truncate (- y 3.0))

-                                          6

-                                          6)))

-          +gdk-event-stop+)

-

-        (on (button-press-event area) (widget event)

-          (format t "BUTTON-PRESS-EVENT ~A~%" event)

-          (if (eql 1 (gdk-event-button-button event))

-            (let ((cr (cairo-create surface))

-                  (x (gdk-event-button-x event))

-                  (y (gdk-event-button-y event)))

-              (cairo-rectangle cr (- x 3.0) (- y 3.0) 6.0 6.0)

-              (cairo-fill cr)

-              (cairo-destroy cr)

-              (gtk-widget-queue-draw-area widget

-                                          (truncate (- x 3.0))

-                                          (truncate (- y 3.0))

-                                          6

-                                          6))

-            (let ((cr (cairo-create surface)))

-              (cairo-set-source-rgb cr 1.0 1.0 1.0)

-              (cairo-paint cr)

-              (cairo-destroy cr)

-              (gtk-widget-queue-draw widget))))

-

-            (gtk-widget-add-events area '(:button-press-mask :pointer-motion-mask))

-            (gtk-container-add frame area)

-            (gtk-container-add window frame)

-            (gtk-widget-show-all window)))))

-

-(example-drawing)

+(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))