steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

pane gadget, clipping work

cvs
Slava Pestov 2005-02-27 21:00:55 +00:00
parent 14862ab4b5
commit 3a1441d0b4
12 changed files with 180 additions and 486 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
examples/gadget-test.factor
View File

@ -15,7 +15,7 @@
! "examples/text-demo.factor" run-file ! "examples/text-demo.factor" run-file
IN: text-demo IN: text-demo
USING: unparser ; USING: listener threads unparser ;
USE: streams USE: streams
USE: sdl USE: sdl
USE: sdl-event USE: sdl-event
@ -49,20 +49,19 @@ USE: words
<line> <gadget> dup moving-actions ; <line> <gadget> dup moving-actions ;
: junk : junk
<default-pile> <pane>
50 [ dup [
[ unparse <label> over add-gadget ] keep [
] repeat ; print-banner
listener
] in-thread
] with-stream ;
: scroller
junk <viewport> dup <slider>
<default-shelf>
[ tuck add-gadget add-gadget ] keep ;
: make-shapes ( -- ) : make-shapes ( -- )
f world get set-gadget-children f world get set-gadget-children
0 default-gap <pile> "pile" set 0 default-gap 0 <pile> "pile" set
! <default-shelf> "shelf" set ! <default-shelf> "shelf" set
! "Close" [ "dialog" get world get remove-gadget ] <button> "shelf" get add-gadget ! "Close" [ "dialog" get world get remove-gadget ] <button> "shelf" get add-gadget
! "New Rectangle" [ drop 100 100 100 100 <funny-rect> dup [ 255 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget ! "New Rectangle" [ drop 100 100 100 100 <funny-rect> dup [ 255 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
@ -74,7 +73,7 @@ USE: words
! "Welcome to Factor " version cat2 <label> "pile" get add-gadget ! "Welcome to Factor " version cat2 <label> "pile" get add-gadget
! "A field." <field> "pile" get add-gadget ! "A field." <field> "pile" get add-gadget
! "Another field." <field> "pile" get add-gadget ! "Another field." <field> "pile" get add-gadget
scroller "pile" get add-gadget junk <scroller> "pile" get add-gadget
"pile" get bevel-border dup "dialog" set ! dup "pile" get bevel-border dup "dialog" set ! dup
! moving-actions ! moving-actions

8
library/bootstrap/boot-stage2.factor
View File

@ -167,8 +167,6 @@ cpu "x86" = "mini" get not and [
"/library/compiler/x86/generator.factor" "/library/compiler/x86/generator.factor"
"/library/compiler/x86/fixnum.factor" "/library/compiler/x86/fixnum.factor"
"/library/ui/line-editor.factor"
"/library/ui/console.factor"
"/library/ui/shapes.factor" "/library/ui/shapes.factor"
"/library/ui/gadgets.factor" "/library/ui/gadgets.factor"
"/library/ui/paint.factor" "/library/ui/paint.factor"
@ -178,11 +176,13 @@ cpu "x86" = "mini" get not and [
"/library/ui/world.factor" "/library/ui/world.factor"
"/library/ui/labels.factor" "/library/ui/labels.factor"
"/library/ui/buttons.factor" "/library/ui/buttons.factor"
"/library/ui/fields.factor" "/library/ui/line-editor.factor"
"/library/ui/editors.factor"
"/library/ui/halo.factor" "/library/ui/halo.factor"
"/library/ui/dialogs.factor" "/library/ui/dialogs.factor"
"/library/ui/events.factor" "/library/ui/events.factor"
"/library/ui/viewports.factor" "/library/ui/scrolling.factor"
"/library/ui/panes.factor"
] [ ] [
dup print dup print
run-resource run-resource

2
library/bootstrap/init-stage2.factor
View File

@ -13,7 +13,7 @@ words unparser kernel-internals console assembler memory ;
"smart-terminal" on "smart-terminal" on
"verbose-compile" on "verbose-compile" on
"compile" on "compile" on
os "win32" = "sdl" "ansi" ? "shell" set ; os "win32" = "ui" "ansi" ? "shell" set ;
: warm-boot ( -- ) : warm-boot ( -- )
#! A fully bootstrapped image has this as the boot #! A fully bootstrapped image has this as the boot

4
library/bootstrap/primitives.factor
View File

@ -193,8 +193,8 @@ vocabularies get [
[ "<tuple>" "kernel-internals" [ [ number ] [ tuple ] ] ] [ "<tuple>" "kernel-internals" [ [ number ] [ tuple ] ] ]
[ "begin-scan" "memory" [ [ ] [ ] ] ] [ "begin-scan" "memory" [ [ ] [ ] ] ]
[ "next-object" "memory" [ [ ] [ object ] ] ] [ "next-object" "memory" [ [ ] [ object ] ] ]
[ "end-scan" "memory" [ [ ] [ object ] ] ] [ "end-scan" "memory" [ [ ] [ ] ] ]
[ "size" "memory" [ [ ] [ object ] ] ] [ "size" "memory" [ [ object ] [ fixnum ] ] ]
] [ ] [
3unlist >r create >r 1 + r> 2dup swap f define r> 3unlist >r create >r 1 + r> 2dup swap f define r>
dup string? [ dup string? [

394
library/ui/console.factor
View File

@ -1,394 +0,0 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004, 2005 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. 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.
!
! THIS SOFTWARE IS PROVIDED ``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
! DEVELOPERS AND 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.
! A graphical console.
!
! To run this code, bootstrap Factor like so:
!
! ./f boot.image.le32
! -libraries:sdl:name=libSDL.so
! -libraries:sdl-gfx:name=libSDL_gfx.
!
! (But all on one line)
!
! Then, start Factor as usual (./f factor.image) and enter this
! at the listener:
!
! USE: shells
! sdl
IN: console
USE: generic
USE: vectors
USE: sdl
USE: sdl-event
USE: sdl-gfx
USE: sdl-video
USE: namespaces
USE: math
USE: kernel
USE: strings
USE: alien
USE: sdl-keyboard
USE: streams
USE: prettyprint
USE: listener
USE: threads
USE: stdio
USE: errors
USE: line-editor
USE: hashtables
USE: lists
USE: sdl-ttf
USE: prettyprint
#! A namespace holding console state.
SYMBOL: console
#! A vector. New lines are pushed on the end.
SYMBOL: lines
#! An integer. Line at top of screen.
SYMBOL: first-line
#! Current X co-ordinate.
SYMBOL: x
#! Current Y co-ordinate.
SYMBOL: y
#! A string buffer.
SYMBOL: output-line
#! A line editor object.
SYMBOL: input-line
#! A TTF_Font* value.
SYMBOL: console-font
#! Font height.
SYMBOL: line-height
#! If this is on, the console will be redrawn on the next event
#! refresh cycle.
SYMBOL: redraw-console
#! The font size is hardcoded here.
: char-width 8 ;
! Scrolling
: visible-lines ( -- n ) height get line-height get /i ;
: total-lines ( -- n ) lines get vector-length ;
: available-lines ( -- ) total-lines first-line get - ;
: fix-first-line ( line -- line )
total-lines visible-lines - 1 + min 0 max ;
: change-first-line ( quot -- )
first-line get
swap call fix-first-line
first-line set ; inline
: line-scroll-up ( -- ) [ 1 - ] change-first-line ;
: line-scroll-down ( -- ) [ 1 + ] change-first-line ;
: page-scroll-up ( -- ) [ visible-lines - ] change-first-line ;
: page-scroll-down ( -- ) [ visible-lines + ] change-first-line ;
: scroll-to-bottom ( -- )
total-lines fix-first-line first-line set ;
! Rendering
: background white ;
: foreground black ;
: cursor red ;
: next-line ( -- )
0 x set line-height get y [ + ] change ;
: draw-line ( str -- )
>r x get y get console-font get r>
foreground 3unlist make-color draw-string
x [ + ] change ;
: clear-display ( -- )
surface get 0 0 width get height get background rgb boxColor ;
: draw-lines ( -- )
visible-lines available-lines min [
dup first-line get +
lines get vector-nth draw-line
next-line
] repeat ;
: blink-interval 500 ;
: draw-cursor ( x -- )
surface get
swap
y get
over 1 +
y get line-height get +
cursor rgb boxColor ;
: draw-current ( -- )
output-line get sbuf>str draw-line ;
: caret-x ( -- x )
x get input-line get [
console-font get caret get line-text get str-head
size-string drop +
] bind ;
: draw-input ( -- )
caret-x >r
input-line get [ line-text get ] bind draw-line
r> draw-cursor ;
: scrollbar-width 16 ;
: scroll-y ( line -- y ) total-lines 1 + / height get * ;
: scrollbar-top ( -- y ) first-line get scroll-y ;
: scrollbar-bottom ( -- y ) first-line get visible-lines + scroll-y ;
: draw-scrollbar ( -- )
surface get
width get scrollbar-width -
scrollbar-top
width get
scrollbar-bottom
black rgb boxColor ;
: draw-console ( -- )
[
0 x set
0 y set
clear-display
draw-lines
height get y get - line-height get >= [
draw-current
draw-input
] when
draw-scrollbar
] with-surface ;
: empty-buffer ( sbuf -- str )
dup sbuf>str 0 rot set-sbuf-length ;
: add-line ( text -- )
lines get vector-push scroll-to-bottom ;
: console-write ( text -- )
"\n" split1 [
swap output-line get sbuf-append
output-line get empty-buffer add-line
] when*
output-line get sbuf-append ;
! The console stream
! Restoring this continuation with a string on the stack returns
! to the caller of stream-readln.
SYMBOL: input-continuation
TUPLE: console-stream console redraw-continuation ;
M: console-stream stream-flush ( stream -- )
stream-auto-flush ;
M: console-stream stream-auto-flush ( stream -- )
console-stream-console [ redraw-console on ] bind ;
M: console-stream stream-readln ( stream -- line )
[
swap [
console-stream-console
[ input-continuation set ] bind
] keep
dup console-stream-redraw-continuation dup [
call
] [
drop f
] ifte
] callcc1 nip ;
M: console-stream stream-write-attr ( string style stream -- )
nip console-stream-console [ console-write ] bind ;
M: console-stream stream-close ( stream -- ) drop ;
! Event handling
SYMBOL: event
: valid-char? 1 255 between? ;
: return-key
input-line get [
commit-history
line-text get
line-clear
] bind
dup console-write "\n" console-write
input-continuation get call ;
GENERIC: handle-event ( event -- ? )
SYMBOL: keymap
{{
[[ [ "RETURN" ] [ return-key ] ]]
[[ [ "BACKSPACE" ] [ input-line get [ backspace ] bind ] ]]
[[ [ "LEFT" ] [ input-line get [ left ] bind ] ]]
[[ [ "RIGHT" ] [ input-line get [ right ] bind ] ]]
[[ [ "UP" ] [ input-line get [ history-prev ] bind ] ]]
[[ [ "SHIFT" "DOWN" ] [ line-scroll-down ] ]]
[[ [ "SHIFT" "UP" ] [ line-scroll-up ] ]]
[[ [ "PAGEDOWN" ] [ page-scroll-down ] ]]
[[ [ "PAGEUP" ] [ page-scroll-up ] ]]
[[ [ "DOWN" ] [ input-line get [ history-next ] bind ] ]]
[[ [ "CTRL" "k" ] [ input-line get [ line-clear ] bind ] ]]
}} keymap set
: input-key? ( event -- ? )
#! Is this a keystroke that potentially inserts input, or
#! does it have modifiers?
keyboard-event-unicode valid-char? ;
: user-input ( char -- )
input-line get [ insert-char ] bind scroll-to-bottom ;
M: key-down-event handle-event ( event -- ? )
dup keyboard-event>binding keymap get hash [
call redraw-console on
] [
dup input-key? [
keyboard-event-unicode user-input redraw-console on
] [
drop
] ifte
] ?ifte t ;
! The y co-ordinate of the start of the drag.
SYMBOL: drag-start-y
! The first line at the time
SYMBOL: drag-start-line
: scrollbar-click ( y -- )
dup scrollbar-top < [
drop page-scroll-up redraw-console on
] [
dup scrollbar-bottom > [
drop page-scroll-down redraw-console on
] [
drag-start-y set
first-line get drag-start-line set
] ifte
] ifte ;
M: button-down-event handle-event ( event -- ? )
dup button-event-x width get scrollbar-width - >= [
button-event-y scrollbar-click
] [
drop
] ifte t ;
M: button-up-event handle-event ( event -- ? )
drop
drag-start-y off
drag-start-line off t ;
M: motion-event handle-event ( event -- ? )
drag-start-y get [
motion-event-y drag-start-y get -
height get / total-lines * drag-start-line get +
>fixnum fix-first-line first-line set
redraw-console on
] [
drop
] ifte t ;
M: resize-event handle-event ( event -- ? )
dup resize-event-w swap resize-event-h
0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
scroll-to-bottom
redraw-console on t ;
M: quit-event handle-event ( event -- ? )
drop f ;
M: alien handle-event ( event -- ? )
drop t ;
: check-event ( -- ? )
#! Check if there is a pending event.
#! Return if we should continue or stop.
event get dup SDL_PollEvent [
handle-event [ check-event ] [ f ] ifte
] [
drop t
] ifte ;
: set-console-font ( font ptsize )
cons dup console-font set
lookup-font TTF_FontHeight line-height set ;
: init-console ( -- )
TTF_Init
"/fonts/VeraMono.ttf" 14 set-console-font
<event> event set
0 first-line set
80 <vector> lines set
<line-editor> input-line set
80 <sbuf> output-line set
1 SDL_EnableUNICODE drop
SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL
SDL_EnableKeyRepeat drop ;
: console-loop ( -- )
redraw-console get [ draw-console redraw-console off ] when
yield check-event [ console-loop ] when ;
: console-quit ( -- )
input-continuation get [ f swap call ] when*
SDL_Quit ;
SYMBOL: escape-continuation
IN: shells
: sdl ( -- )
<namespace> [
640 480 0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
init-console
] extend console set
[
escape-continuation set
[
console get swap <console-stream>
[ print-banner listener ] with-stream
SDL_Quit
( return from start-console word )
escape-continuation get call
] callcc0
console get [
redraw-console on
console-loop
console-quit
] bind
] callcc0 ;

2
library/ui/dialogs.factor
View File

@ -35,7 +35,7 @@ C: dialog ( content -- gadget )
[ dialog-actions ] keep ; [ dialog-actions ] keep ;
: <prompt> ( prompt -- gadget ) : <prompt> ( prompt -- gadget )
0 default-gap <pile> 0 default-gap 0 <pile>
[ >r <label> r> add-gadget ] keep [ >r <label> r> add-gadget ] keep
[ >r "" <field> r> add-gadget ] keep ; [ >r "" <field> r> add-gadget ] keep ;

97
library/ui/fields.factor → library/ui/editors.factor
View File

@ -4,6 +4,9 @@ IN: gadgets
USING: generic kernel lists math namespaces sdl line-editor USING: generic kernel lists math namespaces sdl line-editor
strings ; strings ;
! An editor gadget wraps a line editor object and passes
! gestures to the line editor.
TUPLE: editor line caret delegate ; TUPLE: editor line caret delegate ;
: editor-text ( editor -- text ) : editor-text ( editor -- text )
@ -12,16 +15,6 @@ TUPLE: editor line caret delegate ;
: set-editor-text ( text editor -- ) : set-editor-text ( text editor -- )
editor-line [ set-line-text ] bind ; editor-line [ set-line-text ] bind ;
: <caret> ( -- caret )
0 0 0 0 <plain-rect> <gadget>
dup red background set-paint-property ;
C: editor ( text -- )
0 0 0 0 <line> <gadget> over set-editor-delegate
[ <line-editor> swap set-editor-line ] keep
[ <caret> swap set-editor-caret ] keep
[ set-editor-text ] keep ;
: focus-editor ( editor -- ) : focus-editor ( editor -- )
dup editor-caret over add-gadget dup editor-caret over add-gadget
dup blue foreground set-paint-property relayout ; dup blue foreground set-paint-property relayout ;
@ -30,8 +23,10 @@ C: editor ( text -- )
dup editor-caret unparent dup editor-caret unparent
dup black foreground set-paint-property relayout ; dup black foreground set-paint-property relayout ;
: offset>x ( offset str -- x ) : with-editor ( editor quot -- )
str-head font get swap size-string drop ; #! Execute a quotation in the line editor scope, then
#! update the display.
swap [ editor-line swap bind ] keep relayout ; inline
: run-char-widths ( str -- wlist ) : run-char-widths ( str -- wlist )
#! List of x co-ordinates of each character. #! List of x co-ordinates of each character.
@ -52,12 +47,49 @@ C: editor ( text -- )
: x>offset ( x str -- offset ) : x>offset ( x str -- offset )
0 -rot run-char-widths (x>offset) ; 0 -rot run-char-widths (x>offset) ;
: set-caret-x ( x editor -- )
#! Move the caret to a clicked location.
[ line-text get x>offset caret set ] with-editor ;
: click-editor ( editor -- )
my-hand
2dup relative shape-x pick set-caret-x
request-focus ;
: editor-gestures ( -- hash )
{{
[[ [ gain-focus ] [ focus-editor ] ]]
[[ [ lose-focus ] [ unfocus-editor ] ]]
[[ [ button-down 1 ] [ click-editor ] ]]
[[ [ "BACKSPACE" ] [ [ backspace ] with-editor ] ]]
[[ [ "LEFT" ] [ [ left ] with-editor ] ]]
[[ [ "RIGHT" ] [ [ right ] with-editor ] ]]
[[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]]
}} ;
: <caret> ( -- caret )
0 0 0 0 <plain-rect> <gadget>
dup red background set-paint-property ;
C: editor ( text -- )
0 0 0 0 <line> <gadget> over set-editor-delegate
[ <line-editor> swap set-editor-line ] keep
[ <caret> swap set-editor-caret ] keep
[ set-editor-text ] keep
[ editor-gestures swap set-gadget-gestures ] keep ;
: offset>x ( offset str -- x )
str-head font get swap size-string drop ;
: caret-pos ( editor -- x y ) : caret-pos ( editor -- x y )
editor-line [ caret get line-text get ] bind offset>x 0 ; editor-line [ caret get line-text get ] bind offset>x 0 ;
: caret-size ( editor -- w h ) : caret-size ( editor -- w h )
0 swap shape-h ; 0 swap shape-h ;
M: editor user-input* ( ch field -- ? )
[ insert-char ] with-editor t ;
M: editor layout* ( field -- ) M: editor layout* ( field -- )
dup [ editor-text dup shape-w swap shape-h ] keep dup [ editor-text dup shape-w swap shape-h ] keep
resize-gadget resize-gadget
@ -67,41 +99,6 @@ M: editor layout* ( field -- )
M: editor draw-shape ( label -- ) M: editor draw-shape ( label -- )
dup [ editor-text draw-shape ] with-trans ; dup [ editor-text draw-shape ] with-trans ;
TUPLE: field active? editor delegate ; : <field> ( text -- field )
#! A field is just a stand-alone editor with a border.
: with-editor ( editor quot -- ) <editor> bevel-border dup f bevel-up? set-paint-property ;
swap [ editor-line swap bind ] keep relayout ; inline
: set-caret-x ( x editor -- )
#! Move the caret to a clicked location.
[ line-text get x>offset caret set ] with-editor ;
: click-editor ( editor -- )
my-hand
2dup relative shape-x pick set-caret-x
request-focus ;
: field-border ( gadget -- border )
bevel-border dup f bevel-up? set-paint-property ;
M: field user-input* ( ch field -- ? )
field-editor [ insert-char ] with-editor t ;
: field-gestures ( -- hash )
{{
[[ [ gain-focus ] [ field-editor focus-editor ] ]]
[[ [ lose-focus ] [ field-editor unfocus-editor ] ]]
[[ [ button-down 1 ] [ field-editor click-editor ] ]]
[[ [ "BACKSPACE" ] [ field-editor [ backspace ] with-editor ] ]]
[[ [ "LEFT" ] [ field-editor [ left ] with-editor ] ]]
[[ [ "RIGHT" ] [ field-editor [ right ] with-editor ] ]]
[[ [ "CTRL" "k" ] [ field-editor [ line-clear ] with-editor ] ]]
}} ;
C: field ( text -- field )
#! Note that we want the editor's parent to be the field,
#! not the border.
[ f field-border swap set-field-delegate ] keep
[ >r <editor> dup r> set-field-editor ] keep
[ add-gadget ] keep
[ field-gestures swap set-gadget-gestures ] keep ;

18
library/ui/layouts.factor
View File

@ -24,15 +24,19 @@ M: gadget layout* drop ;
: default-gap 3 ; : default-gap 3 ;
! A pile is a box that lays out its contents vertically. ! A pile is a box that lays out its contents vertically.
TUPLE: pile align gap delegate ; TUPLE: pile align gap fill delegate ;
C: pile ( align gap -- pile ) C: pile ( align gap fill -- pile )
<empty-gadget> over set-pile-delegate #! align: 0 left aligns, 1/2 center, 1 right.
#! gap: between each child.
#! fill: 0 leaves default width, 1 fills to pile width.
[ <empty-gadget> swap set-pile-delegate ] keep
[ set-pile-fill ] keep
[ set-pile-gap ] keep [ set-pile-gap ] keep
[ set-pile-align ] keep ; [ set-pile-align ] keep ;
: <default-pile> ( -- pile ) : <default-pile> 1/2 default-gap 0 <pile> ;
1/2 default-gap <pile> ; : <line-pile> 0 0 1 <pile> ;
: horizontal-layout ( gadget y box -- ) : horizontal-layout ( gadget y box -- )
pick shape-w over shape-w swap - swap pile-align * >fixnum pick shape-w over shape-w swap - swap pile-align * >fixnum
@ -57,8 +61,8 @@ C: shelf ( align gap -- shelf )
pick shape-h over shape-h swap - swap shelf-align * >fixnum pick shape-h over shape-h swap - swap shelf-align * >fixnum
rot move-gadget ; rot move-gadget ;
: <default-shelf> ( -- shelf ) : <default-shelf> 1/2 default-gap <shelf> ;
1/2 default-gap <shelf> ; : <line-shelf> 0 0 <shelf> ;
M: shelf layout* ( pile -- ) M: shelf layout* ( pile -- )
dup shelf-gap over gadget-children run-widths >r >r dup shelf-gap over gadget-children run-widths >r >r

2
library/ui/paint.factor
View File

@ -151,7 +151,7 @@ SYMBOL: clip
] intersect* ; ] intersect* ;
: clip-rect ( x1 x2 y1 y2 -- rect ) : clip-rect ( x1 x2 y1 y2 -- rect )
over - >r >r over - r> swap r> <rectangle> ; over - 1 + >r >r over - 1 + r> swap r> <rectangle> ;
: intersect ( gadget rect -- rect ) : intersect ( gadget rect -- rect )
#! The first gadget's rectangle is relative co-ordinates, #! The first gadget's rectangle is relative co-ordinates,

74
library/ui/panes.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: kernel line-editor lists namespaces streams strings
threads ;
! A pane is an area that can display text.
! output: pile
! current: label
! input: editor
TUPLE: pane output current input continuation delegate ;
: add-output 2dup set-pane-output add-gadget ;
: add-input 2dup set-pane-input add-gadget ;
: <active-line> ( current input -- line )
<line-shelf> [ tuck add-gadget add-gadget ] keep ;
: pane-paint ( pane -- )
[[ "Monospaced" 12 ]] font set-paint-property ;
: pane-return ( pane -- )
[
pane-input [
commit-history line-text get line-clear
] with-editor
] keep
2dup stream-write "\n" over stream-write
pane-continuation call ;
: pane-actions ( line -- )
dup
[ pane-input click-editor ] [ button-down 1 ] set-action
[ pane-return ] [ "RETURN" ] set-action ;
C: pane ( -- pane )
<line-pile> over set-pane-delegate
<line-pile> over add-output
"" <label> dup pick set-pane-current >r
"" <editor> dup pick set-pane-input r>
<active-line> over add-gadget
dup pane-paint
dup pane-actions ;
: add-line ( text pane -- )
>r <label> r> pane-output add-gadget ;
: pane-write-1 ( text pane -- )
pane-current [ label-text swap cat2 ] keep set-label-text ;
: pane-terpri ( pane -- )
dup pane-current dup label-text rot add-line
"" over set-label-text relayout ;
: pane-write ( pane list -- )
2dup car swap pane-write-1
cdr dup [
over pane-terpri pane-write
] [
2drop
] ifte ;
! Panes are streams.
M: pane stream-flush ( stream -- ) relayout ;
M: pane stream-auto-flush ( stream -- ) relayout ;
M: pane stream-readln ( stream -- line )
[ swap set-pane-continuation (yield) ] callcc1 nip ;
M: pane stream-write-attr ( string style stream -- )
nip swap "\n" split pane-write ;
M: pane stream-close ( stream -- ) drop ;

16
library/ui/viewports.factor → library/ui/scrolling.factor
View File

@ -10,7 +10,7 @@ C: viewport ( content -- viewport )
[ add-gadget ] keep [ add-gadget ] keep
0 over set-viewport-x 0 over set-viewport-x
0 over set-viewport-y 0 over set-viewport-y
200 200 pick resize-gadget ; 640 480 pick resize-gadget ;
M: viewport layout* ( viewport -- ) M: viewport layout* ( viewport -- )
dup gadget-children [ dup gadget-children [
@ -70,7 +70,7 @@ C: slider ( viewport -- slider )
[ set-slider-viewport ] keep [ set-slider-viewport ] keep
[ [
f bevel-border dup f bevel-up? set-paint-property f bevel-border dup f bevel-up? set-paint-property
slider-size 200 pick resize-gadget slider-size 480 pick resize-gadget
swap set-slider-delegate swap set-slider-delegate
] keep ] keep
[ <thumb> swap add-thumb ] keep [ <thumb> swap add-thumb ] keep
@ -95,3 +95,15 @@ M: slider layout* ( slider -- )
dup slider-viewport layout* dup slider-viewport layout*
dup shape-w over thumb-height pick slider-thumb resize-gadget dup shape-w over thumb-height pick slider-thumb resize-gadget
0 over thumb-y rot slider-thumb move-gadget ; 0 over thumb-y rot slider-thumb move-gadget ;
TUPLE: scroller viewport slider delegate ;
: add-viewport 2dup set-scroller-viewport add-gadget ;
: add-slider 2dup set-scroller-slider add-gadget ;
C: scroller ( gadget -- scroller )
#! Wrap a scrolling pane around the gadget.
[ <default-shelf> swap set-scroller-delegate ] keep
[ >r <viewport> r> add-viewport ] keep
[ dup scroller-viewport <slider> swap add-slider ] keep ;

28
library/ui/world.factor
View File

@ -66,19 +66,6 @@ DEFER: handle-event
: title ( -- str ) : title ( -- str )
"Factor " version cat2 ; "Factor " version cat2 ;
: start-world ( -- )
#! Start the Factor graphics subsystem with the given screen
#! dimensions.
t world get set-world-running?
world get shape-w world get shape-h 0 SDL_RESIZABLE
[
0 x set 0 y set [
0 0 width get height get <rectangle> clip set
title dup SDL_WM_SetCaption
<event> run-world
] with-screen
] with-scope ;
global [ global [
<world> world set <world> world set
1024 768 world get resize-gadget 1024 768 world get resize-gadget
@ -91,3 +78,18 @@ global [
[[ font [[ "Sans Serif" 16 ]] ]] [[ font [[ "Sans Serif" 16 ]] ]]
}} world get set-gadget-paint }} world get set-gadget-paint
] bind ] bind
IN: shells
: ui ( -- )
#! Start the Factor graphics subsystem with the given screen
#! dimensions.
t world get set-world-running?
world get shape-w world get shape-h 0 SDL_RESIZABLE
[
0 x set 0 y set [
0 0 width get height get <rectangle> clip set
title dup SDL_WM_SetCaption
<event> run-world
] with-screen
] with-scope ;