--- /dev/null
+! 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:
+!
+! "examples/console.factor" run-file
+
+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-keysym
+USE: sdl-keyboard
+USE: streams
+USE: prettyprint
+USE: listener
+USE: threads
+USE: stdio
+USE: errors
+
+#! 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 string buffer.
+SYMBOL: line-editor
+
+! Rendering
+: background HEX: 0000dbff ;
+: foreground HEX: 6d92ffff ;
+: cursor HEX: ffff24ff ;
+
+#! The font size is hardcoded here.
+: line-height 8 ;
+: char-width 8 ;
+
+: next-line ( -- )
+ 0 x set line-height y [ + ] change ;
+
+: draw-line ( str -- )
+ [ surface get x get y get ] keep foreground stringColor
+ str-length char-width * x [ + ] change ;
+
+: clear-display ( -- )
+ surface get 0 0 width get height get background boxColor ;
+
+: visible-lines ( -- n )
+ height get line-height /i ;
+
+: available-lines ( -- )
+ lines get vector-length first-line get - ;
+
+: draw-lines ( -- )
+ visible-lines available-lines min [
+ first-line get +
+ lines get vector-nth draw-line
+ next-line
+ ] times* ;
+
+: draw-cursor ( -- )
+ surface get
+ x get
+ y get
+ x get char-width +
+ y get line-height +
+ cursor boxColor ;
+
+: draw-current ( -- )
+ output-line get sbuf>str draw-line ;
+
+: draw-input ( -- )
+ line-editor get sbuf>str draw-line draw-cursor ;
+
+: draw-console ( -- )
+ [
+ 0 x set
+ 0 y set
+ clear-display
+ draw-lines
+ draw-current
+ draw-input
+ ] with-surface ;
+
+: empty-buffer ( sbuf -- str )
+ dup sbuf>str 0 rot set-sbuf-length ;
+
+: add-line ( text -- )
+ lines get vector-push
+ lines get vector-length succ first-line get - visible-lines -
+ dup 0 >= [
+ first-line [ + ] change
+ ] [
+ drop
+ ] ifte ;
+
+: 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 returns to the
+! top-level console event loop.
+SYMBOL: redraw-continuation
+
+! Restoring this continuation with a string on the stack returns
+! to the caller of freadln.
+SYMBOL: input-continuation
+
+TRAITS: console-stream
+
+C: console-stream ( console console-continuation -- stream )
+ [
+ redraw-continuation set
+ console set
+ ] extend ;
+
+M: console-stream fflush ( stream -- )
+ fauto-flush ;
+
+M: console-stream fauto-flush ( stream -- )
+ [
+ console get [ draw-console ] bind
+ ] bind ;
+
+M: console-stream freadln ( stream -- line )
+ [
+ [
+ console get [ input-continuation set ] bind
+ redraw-continuation get dup [
+ call
+ ] [
+ drop f
+ ] ifte
+ ] callcc1
+ ] bind ;
+
+M: console-stream fwrite-attr ( string style stream -- )
+ [
+ drop
+ console get [ console-write ] bind
+ ] bind ;
+
+M: console-stream fclose ( stream -- ) drop ;
+
+! Event handling
+SYMBOL: event
+
+GENERIC: key-down ( key -- )
+
+PREDICATE: integer null-key
+ dup 0 = swap 255 > or ;
+
+M: null-key key-down ( key -- )
+ drop ;
+
+PREDICATE: integer return-key
+ SDLK_RETURN = ;
+
+M: return-key key-down ( key -- )
+ drop
+ line-editor get empty-buffer
+ dup console-write "\n" console-write
+ input-continuation get call ;
+
+PREDICATE: integer backspace-key
+ SDLK_BACKSPACE = ;
+
+M: backspace-key key-down ( key -- )
+ line-editor get dup sbuf-length 0 = [
+ drop
+ ] [
+ [ sbuf-length pred ] keep set-sbuf-length
+ ] ifte ;
+
+M: integer key-down ( key -- )
+ line-editor get sbuf-append ;
+
+GENERIC: handle-event ( event -- ? )
+
+PREDICATE: alien key-down-event
+ keyboard-event-type SDL_KEYDOWN = ;
+
+M: key-down-event handle-event ( event -- ? )
+ keyboard-event-unicode key-down draw-console t ;
+
+PREDICATE: alien quit-event
+ quit-event-type SDL_QUIT = ;
+
+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 ;
+
+: init-console ( -- )
+ <event> event set
+ 0 first-line set
+ 80 <vector> lines set
+ 80 <sbuf> line-editor set
+ 80 <sbuf> output-line set
+ 1 SDL_EnableUNICODE drop
+ SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL
+ SDL_EnableKeyRepeat drop ;
+
+: console-loop ( -- )
+ yield check-event [ console-loop ] when ;
+
+: console-quit ( -- )
+ redraw-continuation off
+ input-continuation get [ f swap call ] when*
+ SDL_Quit ;
+
+: start-console ( -- )
+ <namespace> [
+ 640 480 32 SDL_HWSURFACE init-screen
+ init-console
+ ] extend console set
+
+ [
+ [
+ console get swap <console-stream>
+ [ [ print-banner listener ] in-thread ] with-stream
+ SDL_Quit
+ call ( return from start-console word )
+ ] callcc0
+
+ console get [
+ draw-console
+ console-loop
+ console-quit
+ ] bind
+ ] callcc0 ;
+
+start-console
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 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.
+
+IN: sdl-keyboard
+USE: alien
+
+: SDL_EnableUNICODE ( enable -- )
+ "int" "sdl" "SDL_EnableUNICODE" [ "int" ] alien-invoke ;
+
+: SDL_DEFAULT_REPEAT_DELAY 500 ;
+: SDL_DEFAULT_REPEAT_INTERVAL 30 ;
+
+: SDL_EnableKeyRepeat ( delay interval -- )
+ "int" "sdl" "SDL_EnableKeyRepeat" [ "int" "int" ] alien-invoke ;
projects / factor.git / commitdiff