398 lines
10 KiB
Factor
398 lines
10 KiB
Factor
! :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
|
|
|
|
#! 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 make-color background 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 freadln.
|
|
SYMBOL: input-continuation
|
|
|
|
TUPLE: console-stream console redraw-continuation ;
|
|
|
|
C: console-stream ( console console-continuation -- stream )
|
|
[ set-console-stream-redraw-continuation ] keep
|
|
[ set-console-stream-console ] keep ;
|
|
|
|
M: console-stream fflush ( stream -- )
|
|
fauto-flush ;
|
|
|
|
M: console-stream fauto-flush ( stream -- )
|
|
console-stream-console [ redraw-console on ] bind ;
|
|
|
|
M: console-stream freadln ( 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 fwrite-attr ( string style stream -- )
|
|
nip console-stream-console [ console-write ] bind ;
|
|
|
|
M: console-stream fclose ( 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 )
|
|
font dup console-font set
|
|
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
|
|
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 ;
|