#|

 This software is Copyright (c) 2005 Peter Herth <herth@peter-herth.de>

 Peter Herth grants you the rights to distribute
 and use this software as governed by the terms
 of the Lisp Lesser GNU Public License
 (http://opensource.franz.com/preamble.html),
 known as the LLGPL.
 
 This program is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU General Public License for more details.
 
|#

#|
Notebook widget wrapper by Frank Buss

Example usage:

 (defun test-note-book ()
  (with-ltk ()
   (let* ((nb (make-instance 'note-book))
          (page1 (insert-page nb "end" :text "Page 1"))
          (page2 (insert-page nb "end" :text "Page 2"))
          (label1 (make-instance 'label :master page1 :text "Hello World!"))
          (label2 (make-instance 'label :master page2 :text "This is the 2nd page")))
     (pack nb)
     (pack label1 :padx 20 :pady 20)
     (pack label2)
     (compute-size nb)
     (raise-page page1))))

I've decided to use an extra class for the note-book-page, because
referencing it by name, like in the Tk interface, doesn't look like
the way the other widgets are used. Only the functions I need are
implemented, perhaps someone can complete it.

|#

(defpackage :bwidget
  (:use :common-lisp
	:ltk
	)
  (:export
   	#:note-book-page
	#:note-book
	#:compute-size
	#:insert-page
	#:delete-page
	#:raise-page
   ))

(in-package :bwidget)

(eval-when (:load-toplevel)
  (setf *init-wish-hook* (append *init-wish-hook*
				 (list (lambda ()
					 (send-wish "package require BWidget")
				       )))))

(defclass note-book-page (widget)
  ((page-name :accessor page-name :initarg :page-name :initform nil)
   (note-book :accessor note-book :initarg :note-book :initform nil)))

(defclass note-book (widget) ())

(defmethod initialize-instance :after ((nb note-book) &key font activebackground 
                                       activeforeground background borderwidth
                                       disabledforeground foreground repeatdelay
                                       repeatinterval arcradius height homogeneous
                                       side tabbevelsize tabpady width)  
  (format-wish "NoteBook ~a ~@[ -font ~(~A~)~]~
     ~@[ -activebackground ~(~A~)~]~@[ -activeforeground ~(~A~)~]~
     ~@[ -background ~(~A~)~]~@[ -borderwidth ~(~A~)~]~
     ~@[ -disabledforeground ~(~A~)~]~@[ -foreground ~(~A~)~]~
     ~@[ -repeatdelay ~(~A~)~]~@[ -repeatinterval ~(~A~)~]~
     ~@[ -arcradius ~(~A~)~]~@[ -height ~(~A~)~]~@[ -homogeneous ~(~A~)~]~
     ~@[ -side ~(~A~)~]~@[ -tabbevelsize ~(~A~)~]~@[ -tabpady ~(~A~)~]~
     ~@[ -width ~(~A~)~]"
               (widget-path nb) font activebackground activeforeground background
               borderwidth disabledforeground foreground repeatdelay repeatinterval
               arcradius height homogeneous side tabbevelsize tabpady width))

(defmethod insert-page ((nb note-book) index &key text)
  (let ((page-name (ltk::create-name)))
    (format-wish "senddata [~a insert ~a ~a ~@[ -text {~A}~]]"
                 (widget-path nb) index page-name text)
    (let ((path (ltk::read-data)))
      (if path
          (make-instance 'note-book-page 
                         :page-name page-name
                         :note-book nb
                         :path (string-downcase path))
        (error "error while inserting page")))))

(defmethod raise-page ((nbp note-book-page))
  (format-wish "~a raise ~a" (widget-path (note-book nbp)) (page-name nbp)))

(defmethod delete-page ((nbp note-book-page))
  (format-wish "~a delete ~a" (widget-path (note-book nbp)) (page-name nbp)))

(defmethod compute-size ((nb note-book))
  (format-wish "~a compute_size" (widget-path nb)))