pane gadget, clipping work
Slava Pestov
parent
14862ab4b5
commit
3a1441d0b4
|
|
@ -15,7 +15,7 @@
|
|||
! "examples/text-demo.factor" run-file
|
||||
|
||||
IN: text-demo
|
||||
USING: unparser ;
|
||||
USING: listener threads unparser ;
|
||||
USE: streams
|
||||
USE: sdl
|
||||
USE: sdl-event
|
||||
|
|
@ -49,20 +49,19 @@ USE: words
|
|||
<line> <gadget> dup moving-actions ;
|
||||
|
||||
: junk
|
||||
<default-pile>
|
||||
50 [
|
||||
[ unparse <label> over add-gadget ] keep
|
||||
] repeat ;
|
||||
<pane>
|
||||
dup [
|
||||
[
|
||||
print-banner
|
||||
listener
|
||||
] in-thread
|
||||
] with-stream ;
|
||||
|
||||
: scroller
|
||||
junk <viewport> dup <slider>
|
||||
<default-shelf>
|
||||
[ tuck add-gadget add-gadget ] keep ;
|
||||
|
||||
: make-shapes ( -- )
|
||||
f world get set-gadget-children
|
||||
|
||||
0 default-gap <pile> "pile" set
|
||||
0 default-gap 0 <pile> "pile" set
|
||||
! <default-shelf> "shelf" set
|
||||
! "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
|
||||
|
|
@ -74,7 +73,7 @@ USE: words
|
|||
! "Welcome to Factor " version cat2 <label> "pile" get add-gadget
|
||||
! "A 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
|
||||
! moving-actions
|
||||
|
|
|
|||
|
|
@ -167,8 +167,6 @@ cpu "x86" = "mini" get not and [
|
|||
"/library/compiler/x86/generator.factor"
|
||||
"/library/compiler/x86/fixnum.factor"
|
||||
|
||||
"/library/ui/line-editor.factor"
|
||||
"/library/ui/console.factor"
|
||||
"/library/ui/shapes.factor"
|
||||
"/library/ui/gadgets.factor"
|
||||
"/library/ui/paint.factor"
|
||||
|
|
@ -178,11 +176,13 @@ cpu "x86" = "mini" get not and [
|
|||
"/library/ui/world.factor"
|
||||
"/library/ui/labels.factor"
|
||||
"/library/ui/buttons.factor"
|
||||
"/library/ui/fields.factor"
|
||||
"/library/ui/line-editor.factor"
|
||||
"/library/ui/editors.factor"
|
||||
"/library/ui/halo.factor"
|
||||
"/library/ui/dialogs.factor"
|
||||
"/library/ui/events.factor"
|
||||
"/library/ui/viewports.factor"
|
||||
"/library/ui/scrolling.factor"
|
||||
"/library/ui/panes.factor"
|
||||
] [
|
||||
dup print
|
||||
run-resource
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ words unparser kernel-internals console assembler memory ;
|
|||
"smart-terminal" on
|
||||
"verbose-compile" on
|
||||
"compile" on
|
||||
os "win32" = "sdl" "ansi" ? "shell" set ;
|
||||
os "win32" = "ui" "ansi" ? "shell" set ;
|
||||
|
||||
: warm-boot ( -- )
|
||||
#! A fully bootstrapped image has this as the boot
|
||||
|
|
|
|||
|
|
@ -193,8 +193,8 @@ vocabularies get [
|
|||
[ "<tuple>" "kernel-internals" [ [ number ] [ tuple ] ] ]
|
||||
[ "begin-scan" "memory" [ [ ] [ ] ] ]
|
||||
[ "next-object" "memory" [ [ ] [ object ] ] ]
|
||||
[ "end-scan" "memory" [ [ ] [ object ] ] ]
|
||||
[ "size" "memory" [ [ ] [ object ] ] ]
|
||||
[ "end-scan" "memory" [ [ ] [ ] ] ]
|
||||
[ "size" "memory" [ [ object ] [ fixnum ] ] ]
|
||||
] [
|
||||
3unlist >r create >r 1 + r> 2dup swap f define r>
|
||||
dup string? [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -35,7 +35,7 @@ C: dialog ( content -- gadget )
|
|||
[ dialog-actions ] keep ;
|
||||
|
||||
: <prompt> ( prompt -- gadget )
|
||||
0 default-gap <pile>
|
||||
0 default-gap 0 <pile>
|
||||
[ >r <label> r> add-gadget ] keep
|
||||
[ >r "" <field> r> add-gadget ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,9 @@ IN: gadgets
|
|||
USING: generic kernel lists math namespaces sdl line-editor
|
||||
strings ;
|
||||
|
||||
! An editor gadget wraps a line editor object and passes
|
||||
! gestures to the line editor.
|
||||
|
||||
TUPLE: editor line caret delegate ;
|
||||
|
||||
: editor-text ( editor -- text )
|
||||
|
|
@ -12,16 +15,6 @@ TUPLE: editor line caret delegate ;
|
|||
: set-editor-text ( text editor -- )
|
||||
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 -- )
|
||||
dup editor-caret over add-gadget
|
||||
dup blue foreground set-paint-property relayout ;
|
||||
|
|
@ -30,8 +23,10 @@ C: editor ( text -- )
|
|||
dup editor-caret unparent
|
||||
dup black foreground set-paint-property relayout ;
|
||||
|
||||
: offset>x ( offset str -- x )
|
||||
str-head font get swap size-string drop ;
|
||||
: with-editor ( editor quot -- )
|
||||
#! 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 )
|
||||
#! List of x co-ordinates of each character.
|
||||
|
|
@ -52,12 +47,49 @@ C: editor ( text -- )
|
|||
: x>offset ( x str -- 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 )
|
||||
editor-line [ caret get line-text get ] bind offset>x 0 ;
|
||||
|
||||
: caret-size ( editor -- w h )
|
||||
0 swap shape-h ;
|
||||
|
||||
M: editor user-input* ( ch field -- ? )
|
||||
[ insert-char ] with-editor t ;
|
||||
|
||||
M: editor layout* ( field -- )
|
||||
dup [ editor-text dup shape-w swap shape-h ] keep
|
||||
resize-gadget
|
||||
|
|
@ -67,41 +99,6 @@ M: editor layout* ( field -- )
|
|||
M: editor draw-shape ( label -- )
|
||||
dup [ editor-text draw-shape ] with-trans ;
|
||||
|
||||
TUPLE: field active? editor delegate ;
|
||||
|
||||
: with-editor ( editor quot -- )
|
||||
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 ;
|
||||
: <field> ( text -- field )
|
||||
#! A field is just a stand-alone editor with a border.
|
||||
<editor> bevel-border dup f bevel-up? set-paint-property ;
|
||||
|
|
@ -24,15 +24,19 @@ M: gadget layout* drop ;
|
|||
: default-gap 3 ;
|
||||
|
||||
! 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 )
|
||||
<empty-gadget> over set-pile-delegate
|
||||
C: pile ( align gap fill -- pile )
|
||||
#! 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-align ] keep ;
|
||||
|
||||
: <default-pile> ( -- pile )
|
||||
1/2 default-gap <pile> ;
|
||||
: <default-pile> 1/2 default-gap 0 <pile> ;
|
||||
: <line-pile> 0 0 1 <pile> ;
|
||||
|
||||
: horizontal-layout ( gadget y box -- )
|
||||
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
|
||||
rot move-gadget ;
|
||||
|
||||
: <default-shelf> ( -- shelf )
|
||||
1/2 default-gap <shelf> ;
|
||||
: <default-shelf> 1/2 default-gap <shelf> ;
|
||||
: <line-shelf> 0 0 <shelf> ;
|
||||
|
||||
M: shelf layout* ( pile -- )
|
||||
dup shelf-gap over gadget-children run-widths >r >r
|
||||
|
|
|
|||
|
|
@ -151,7 +151,7 @@ SYMBOL: clip
|
|||
] intersect* ;
|
||||
|
||||
: 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 )
|
||||
#! The first gadget's rectangle is relative co-ordinates,
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -10,7 +10,7 @@ C: viewport ( content -- viewport )
|
|||
[ add-gadget ] keep
|
||||
0 over set-viewport-x
|
||||
0 over set-viewport-y
|
||||
200 200 pick resize-gadget ;
|
||||
640 480 pick resize-gadget ;
|
||||
|
||||
M: viewport layout* ( viewport -- )
|
||||
dup gadget-children [
|
||||
|
|
@ -70,7 +70,7 @@ C: slider ( viewport -- slider )
|
|||
[ set-slider-viewport ] keep
|
||||
[
|
||||
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
|
||||
] keep
|
||||
[ <thumb> swap add-thumb ] keep
|
||||
|
|
@ -95,3 +95,15 @@ M: slider layout* ( slider -- )
|
|||
dup slider-viewport layout*
|
||||
dup shape-w over thumb-height pick slider-thumb resize-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 ;
|
||||
|
||||
|
|
@ -66,19 +66,6 @@ DEFER: handle-event
|
|||
: title ( -- str )
|
||||
"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 [
|
||||
<world> world set
|
||||
1024 768 world get resize-gadget
|
||||
|
|
@ -91,3 +78,18 @@ global [
|
|||
[[ font [[ "Sans Serif" 16 ]] ]]
|
||||
}} world get set-gadget-paint
|
||||
] 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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue