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