2005-07-18 18:14:13 -04:00
|
|
|
! Copyright (C) 2005 Slava Pestov.
|
|
|
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
2005-08-31 21:06:13 -04:00
|
|
|
IN: gadgets-books
|
|
|
|
|
USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
|
2005-10-27 16:17:50 -04:00
|
|
|
gadgets-theme generic kernel lists math namespaces sequences
|
|
|
|
|
styles ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
|
|
|
|
TUPLE: book page ;
|
|
|
|
|
|
|
|
|
|
C: book ( pages -- book )
|
2005-10-09 21:27:14 -04:00
|
|
|
[ >r make-stack r> set-gadget-delegate ] keep
|
|
|
|
|
0 over set-book-page ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
|
|
|
|
M: book layout* ( book -- )
|
2005-09-27 00:24:42 -04:00
|
|
|
dup delegate layout*
|
2005-09-28 23:29:00 -04:00
|
|
|
dup gadget-children [ hide-gadget ] each
|
2005-07-18 18:14:13 -04:00
|
|
|
dup book-page swap gadget-children nth
|
2005-09-28 23:29:00 -04:00
|
|
|
[ show-gadget ] when* ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
|
|
|
|
: show-page ( n book -- )
|
|
|
|
|
[ gadget-children length rem ] keep
|
2005-09-25 20:41:49 -04:00
|
|
|
[ set-book-page ] keep relayout-1 ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
2005-08-26 21:42:43 -04:00
|
|
|
: first-page ( book -- ) 0 swap show-page ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
2005-09-16 22:47:28 -04:00
|
|
|
: prev-page ( book -- ) [ book-page 1- ] keep show-page ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
2005-09-16 22:47:28 -04:00
|
|
|
: next-page ( book -- ) [ book-page 1+ ] keep show-page ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
2005-08-26 21:42:43 -04:00
|
|
|
: last-page ( book -- ) -1 swap show-page ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
2005-08-26 21:42:43 -04:00
|
|
|
TUPLE: book-browser book ;
|
2005-07-18 18:14:13 -04:00
|
|
|
|
2005-08-26 21:42:43 -04:00
|
|
|
: find-book ( gadget -- )
|
|
|
|
|
[ book-browser? ] find-parent book-browser-book ;
|
|
|
|
|
|
2005-09-28 23:29:00 -04:00
|
|
|
: <book-button> ( polygon quot -- button )
|
2005-10-27 16:17:50 -04:00
|
|
|
\ find-book swons >r gray swap <polygon-gadget> r>
|
2005-10-25 21:52:26 -04:00
|
|
|
<bevel-button> ;
|
2005-09-28 23:29:00 -04:00
|
|
|
|
2005-08-26 21:42:43 -04:00
|
|
|
: <book-buttons> ( book -- gadget )
|
|
|
|
|
[
|
2005-09-28 23:29:00 -04:00
|
|
|
arrow-|left [ first-page ] <book-button> ,
|
|
|
|
|
arrow-left [ prev-page ] <book-button> ,
|
|
|
|
|
arrow-right [ next-page ] <book-button> ,
|
|
|
|
|
arrow-right| [ last-page ] <book-button> ,
|
2005-10-29 16:53:47 -04:00
|
|
|
] @{ }@ make make-shelf ;
|
2005-08-26 21:42:43 -04:00
|
|
|
|
|
|
|
|
C: book-browser ( book -- gadget )
|
2005-10-09 21:27:14 -04:00
|
|
|
dup delegate>frame
|
2005-09-27 14:12:17 -04:00
|
|
|
<book-buttons> over @top frame-add
|
|
|
|
|
[ 2dup set-book-browser-book @center frame-add ] keep ;
|
