some cleanups
Slava Pestov
parent
3cb8a1e63d
commit
d8be679fcc
|
|
@ -51,6 +51,17 @@ SYMBOL: d
|
||||||
iterate-dejong 2dup scale-dejong rect> white rgb pixel
|
iterate-dejong 2dup scale-dejong rect> white rgb pixel
|
||||||
] times 2drop ; compiled
|
] times 2drop ; compiled
|
||||||
|
|
||||||
|
: event-loop ( event -- )
|
||||||
|
dup SDL_WaitEvent [
|
||||||
|
dup event-type SDL_QUIT = [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
event-loop
|
||||||
|
] ifte
|
||||||
|
] [
|
||||||
|
drop
|
||||||
|
] ifte ; compiled
|
||||||
|
|
||||||
: dejong ( -- )
|
: dejong ( -- )
|
||||||
! Fiddle with these four values!
|
! Fiddle with these four values!
|
||||||
1.0 a set
|
1.0 a set
|
||||||
|
|
|
||||||
|
|
@ -30,6 +30,50 @@ USE: prettyprint
|
||||||
USE: stdio
|
USE: stdio
|
||||||
USE: test
|
USE: test
|
||||||
|
|
||||||
|
: f_ ( h s v i -- f ) >r swap rot >r 2dup r> 6 * r> - ;
|
||||||
|
: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
|
||||||
|
: q ( v s f -- q ) * neg 1 + * ;
|
||||||
|
: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
|
||||||
|
|
||||||
|
: mod-cond ( p vector -- )
|
||||||
|
#! Call p mod q'th entry of the vector of quotations, where
|
||||||
|
#! q is the length of the vector. The value q remains on the
|
||||||
|
#! stack.
|
||||||
|
[ dupd vector-length mod ] keep vector-nth call ;
|
||||||
|
|
||||||
|
: hsv>rgb ( h s v -- r g b )
|
||||||
|
pick 6 * >fixnum {
|
||||||
|
[ f_ t_ p swap ( v p t ) ]
|
||||||
|
[ f_ q p -rot ( q v p ) ]
|
||||||
|
[ f_ t_ p swapd ( p v t ) ]
|
||||||
|
[ f_ q p rot ( p q v ) ]
|
||||||
|
[ f_ t_ p swap rot ( t p v ) ]
|
||||||
|
[ f_ q p ( v p q ) ]
|
||||||
|
} mod-cond ;
|
||||||
|
|
||||||
|
[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
|
||||||
|
|
||||||
|
[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
|
||||||
|
[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
|
||||||
|
|
||||||
|
[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
|
||||||
|
[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
|
||||||
|
|
||||||
|
[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
|
||||||
|
[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
|
||||||
|
|
||||||
|
[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
|
||||||
|
[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
|
||||||
|
|
||||||
|
[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
|
||||||
|
[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
|
||||||
|
|
||||||
|
[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
|
||||||
|
[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
|
||||||
|
|
||||||
|
[ 1 0 0 ] [ 1 1 1 hsv>rgb ] unit-test
|
||||||
|
[ 1/6 1/9 1/9 ] [ 1 1/3 1/6 hsv>rgb ] unit-test
|
||||||
|
|
||||||
: scale 255 * >fixnum ;
|
: scale 255 * >fixnum ;
|
||||||
|
|
||||||
: scale-rgb ( r g b a -- n )
|
: scale-rgb ( r g b a -- n )
|
||||||
|
|
@ -88,6 +132,17 @@ SYMBOL: center
|
||||||
] ifte
|
] ifte
|
||||||
] with-pixels ; compiled
|
] with-pixels ; compiled
|
||||||
|
|
||||||
|
: event-loop ( event -- )
|
||||||
|
dup SDL_WaitEvent [
|
||||||
|
dup event-type SDL_QUIT = [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
event-loop
|
||||||
|
] ifte
|
||||||
|
] [
|
||||||
|
drop
|
||||||
|
] ifte ; compiled
|
||||||
|
|
||||||
: mandel ( -- )
|
: mandel ( -- )
|
||||||
1280 1024 0 SDL_HWSURFACE [
|
1280 1024 0 SDL_HWSURFACE [
|
||||||
[
|
[
|
||||||
|
|
|
||||||
|
|
@ -121,7 +121,6 @@ IN: alien : add-library 3drop ;
|
||||||
"/library/sdl/sdl-keyboard.factor"
|
"/library/sdl/sdl-keyboard.factor"
|
||||||
"/library/sdl/sdl-ttf.factor"
|
"/library/sdl/sdl-ttf.factor"
|
||||||
"/library/sdl/sdl-utils.factor"
|
"/library/sdl/sdl-utils.factor"
|
||||||
"/library/sdl/hsv.factor"
|
|
||||||
|
|
||||||
"/library/bootstrap/image.factor"
|
"/library/bootstrap/image.factor"
|
||||||
|
|
||||||
|
|
@ -168,6 +167,7 @@ cpu "x86" = "mini" get not and [
|
||||||
"/library/compiler/x86/fixnum.factor"
|
"/library/compiler/x86/fixnum.factor"
|
||||||
|
|
||||||
"/library/ui/shapes.factor"
|
"/library/ui/shapes.factor"
|
||||||
|
"/library/ui/text.factor"
|
||||||
"/library/ui/gadgets.factor"
|
"/library/ui/gadgets.factor"
|
||||||
"/library/ui/paint.factor"
|
"/library/ui/paint.factor"
|
||||||
"/library/ui/gestures.factor"
|
"/library/ui/gestures.factor"
|
||||||
|
|
|
||||||
|
|
@ -15,6 +15,8 @@ unparser ;
|
||||||
! parameter, or a missing abi parameter indicates the cdecl ABI
|
! parameter, or a missing abi parameter indicates the cdecl ABI
|
||||||
! should be used, which is common on Unix.
|
! should be used, which is common on Unix.
|
||||||
|
|
||||||
|
: null? ( alien -- ? ) dup [ alien-address 0 = ] when ;
|
||||||
|
|
||||||
M: alien hashcode ( obj -- n )
|
M: alien hashcode ( obj -- n )
|
||||||
alien-address >fixnum ;
|
alien-address >fixnum ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,35 +0,0 @@
|
||||||
! Contains definition of the hsv>rgb word for converting
|
|
||||||
! Hue/Saturation/Value color values to RGB.
|
|
||||||
|
|
||||||
! This thing is GPL, hsv->rgb is a translation to Common Lisp of a
|
|
||||||
! function found in color_sys.py in Python 2.3.0
|
|
||||||
|
|
||||||
! Translated to Factor by Slava Pestov.
|
|
||||||
|
|
||||||
IN: sdl
|
|
||||||
USE: kernel
|
|
||||||
USE: lists
|
|
||||||
USE: math
|
|
||||||
USE: namespaces
|
|
||||||
USE: vectors
|
|
||||||
|
|
||||||
: f_ ( h s v i -- f ) >r swap rot >r 2dup r> 6 * r> - ;
|
|
||||||
: p ( v s x -- v p x ) >r dupd neg 1 + * r> ;
|
|
||||||
: q ( v s f -- q ) * neg 1 + * ;
|
|
||||||
: t_ ( v s f -- t_ ) neg 1 + * neg 1 + * ;
|
|
||||||
|
|
||||||
: mod-cond ( p vector -- )
|
|
||||||
#! Call p mod q'th entry of the vector of quotations, where
|
|
||||||
#! q is the length of the vector. The value q remains on the
|
|
||||||
#! stack.
|
|
||||||
[ dupd vector-length mod ] keep vector-nth call ;
|
|
||||||
|
|
||||||
: hsv>rgb ( h s v -- r g b )
|
|
||||||
pick 6 * >fixnum {
|
|
||||||
[ f_ t_ p swap ( v p t ) ]
|
|
||||||
[ f_ q p -rot ( q v p ) ]
|
|
||||||
[ f_ t_ p swapd ( p v t ) ]
|
|
||||||
[ f_ q p rot ( p q v ) ]
|
|
||||||
[ f_ t_ p swap rot ( t p v ) ]
|
|
||||||
[ f_ q p ( v p q ) ]
|
|
||||||
} mod-cond ;
|
|
||||||
|
|
@ -1,34 +1,6 @@
|
||||||
! :folding=indent:collapseFolds=1:sidekick.parser=none:
|
|
||||||
|
|
||||||
! $Id$
|
|
||||||
!
|
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
!
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
! Redistribution and use in source and binary forms, with or without
|
IN: sdl USING: alien generic kernel ;
|
||||||
! 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-event
|
|
||||||
USE: alien
|
|
||||||
USE: generic
|
|
||||||
USE: kernel
|
|
||||||
|
|
||||||
BEGIN-ENUM: 0
|
BEGIN-ENUM: 0
|
||||||
ENUM: SDL_NOEVENT ! Unused (do not remove)
|
ENUM: SDL_NOEVENT ! Unused (do not remove)
|
||||||
|
|
|
||||||
|
|
@ -1,32 +1,6 @@
|
||||||
! :folding=indent:collapseFolds=1:sidekick.parser=none:
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
! $Id$
|
IN: sdl USING: alien ;
|
||||||
!
|
|
||||||
! 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-gfx
|
|
||||||
USE: alien
|
|
||||||
|
|
||||||
: pixelColor ( surface x y color -- )
|
: pixelColor ( surface x y color -- )
|
||||||
"void" "sdl-gfx" "pixelColor"
|
"void" "sdl-gfx" "pixelColor"
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,7 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: sdl-keyboard
|
IN: sdl
|
||||||
USING: alien lists sdl-keysym namespaces sdl-event kernel
|
USING: alien lists namespaces kernel math hashtables ;
|
||||||
math hashtables ;
|
|
||||||
|
|
||||||
: SDL_EnableUNICODE ( enable -- )
|
: SDL_EnableUNICODE ( enable -- )
|
||||||
"int" "sdl" "SDL_EnableUNICODE" [ "int" ] alien-invoke ;
|
"int" "sdl" "SDL_EnableUNICODE" [ "int" ] alien-invoke ;
|
||||||
|
|
|
||||||
|
|
@ -1,32 +1,6 @@
|
||||||
! :folding=indent:collapseFolds=1:
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
! $Id$
|
IN: sdl USING: namespaces ;
|
||||||
!
|
|
||||||
! 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: namespaces
|
|
||||||
|
|
||||||
! Here we smash left/right control/shift/alt for convinience.
|
! Here we smash left/right control/shift/alt for convinience.
|
||||||
! Later, something better needs to be done.
|
! Later, something better needs to be done.
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: sdl-ttf
|
IN: sdl
|
||||||
USE: alien
|
USE: alien
|
||||||
|
|
||||||
: UNICODE_BOM_NATIVE HEX: FEFF ;
|
: UNICODE_BOM_NATIVE HEX: FEFF ;
|
||||||
|
|
|
||||||
|
|
@ -1,27 +1,7 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: sdl
|
IN: sdl
|
||||||
USING: alien math namespaces compiler words parser kernel errors
|
USING: kernel lists math namespaces ;
|
||||||
lists prettyprint sdl-event sdl-gfx sdl-keyboard sdl-video
|
|
||||||
streams strings sdl-ttf hashtables ;
|
|
||||||
|
|
||||||
SYMBOL: surface
|
|
||||||
SYMBOL: width
|
|
||||||
SYMBOL: height
|
|
||||||
SYMBOL: bpp
|
|
||||||
SYMBOL: surface
|
|
||||||
|
|
||||||
: init-screen ( width height bpp flags -- )
|
|
||||||
>r 3dup bpp set height set width set r>
|
|
||||||
SDL_SetVideoMode surface set ;
|
|
||||||
|
|
||||||
: with-screen ( width height bpp flags quot -- )
|
|
||||||
#! Set up SDL graphics and call the quotation.
|
|
||||||
SDL_INIT_EVERYTHING SDL_Init drop TTF_Init
|
|
||||||
1 SDL_EnableUNICODE drop
|
|
||||||
SDL_DEFAULT_REPEAT_DELAY SDL_DEFAULT_REPEAT_INTERVAL
|
|
||||||
SDL_EnableKeyRepeat drop
|
|
||||||
[ >r init-screen r> call SDL_Quit ] with-scope ; inline
|
|
||||||
|
|
||||||
: rgb ( [ r g b ] -- n )
|
: rgb ( [ r g b ] -- n )
|
||||||
3unlist
|
3unlist
|
||||||
|
|
@ -45,9 +25,6 @@ SYMBOL: surface
|
||||||
: green [ 0 255 0 ] ;
|
: green [ 0 255 0 ] ;
|
||||||
: blue [ 0 0 255 ] ;
|
: blue [ 0 0 255 ] ;
|
||||||
|
|
||||||
: clear-surface ( color -- )
|
|
||||||
>r surface get 0 0 width get height get r> boxColor ;
|
|
||||||
|
|
||||||
: with-pixels ( quot -- )
|
: with-pixels ( quot -- )
|
||||||
width get [
|
width get [
|
||||||
height get [
|
height get [
|
||||||
|
|
@ -66,80 +43,3 @@ SYMBOL: surface
|
||||||
slip
|
slip
|
||||||
] ifte SDL_Flip drop
|
] ifte SDL_Flip drop
|
||||||
] with-scope ; inline
|
] with-scope ; inline
|
||||||
|
|
||||||
: event-loop ( event -- )
|
|
||||||
dup SDL_WaitEvent [
|
|
||||||
dup event-type SDL_QUIT = [
|
|
||||||
drop
|
|
||||||
] [
|
|
||||||
event-loop
|
|
||||||
] ifte
|
|
||||||
] [
|
|
||||||
drop
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
SYMBOL: fonts
|
|
||||||
|
|
||||||
: null? ( alien -- ? )
|
|
||||||
dup [ alien-address 0 = ] when ;
|
|
||||||
|
|
||||||
: <font> ( name ptsize -- font )
|
|
||||||
>r resource-path swap cat2 r> TTF_OpenFont ;
|
|
||||||
|
|
||||||
SYMBOL: logical-fonts
|
|
||||||
|
|
||||||
: logical-font ( name -- name )
|
|
||||||
dup logical-fonts get hash dup [ nip ] [ drop ] ifte ;
|
|
||||||
|
|
||||||
global [
|
|
||||||
{{
|
|
||||||
[[ "Monospaced" "/fonts/VeraMono.ttf" ]]
|
|
||||||
[[ "Serif" "/fonts/VeraSe.ttf" ]]
|
|
||||||
[[ "Sans Serif" "/fonts/Vera.ttf" ]]
|
|
||||||
}} logical-fonts set
|
|
||||||
] bind
|
|
||||||
|
|
||||||
: (lookup-font) ( [[ name ptsize ]] -- font )
|
|
||||||
unswons logical-font swons dup get dup alien? [
|
|
||||||
dup alien-address 0 = [
|
|
||||||
drop f
|
|
||||||
] when
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: lookup-font ( [[ name ptsize ]] -- font )
|
|
||||||
fonts get [
|
|
||||||
(lookup-font) [
|
|
||||||
nip
|
|
||||||
] [
|
|
||||||
[ uncons <font> dup ] keep set
|
|
||||||
] ifte*
|
|
||||||
] bind ;
|
|
||||||
|
|
||||||
: make-rect ( x y w h -- rect )
|
|
||||||
<rect>
|
|
||||||
[ set-rect-h ] keep
|
|
||||||
[ set-rect-w ] keep
|
|
||||||
[ set-rect-y ] keep
|
|
||||||
[ set-rect-x ] keep ;
|
|
||||||
|
|
||||||
: surface-rect ( x y surface -- rect )
|
|
||||||
dup surface-w swap surface-h make-rect ;
|
|
||||||
|
|
||||||
: draw-surface ( x y surface -- )
|
|
||||||
surface get SDL_UnlockSurface
|
|
||||||
[
|
|
||||||
[ surface-rect ] keep swap surface get 0 0
|
|
||||||
] keep surface-rect swap rot SDL_UpperBlit drop
|
|
||||||
surface get dup must-lock-surface? [
|
|
||||||
SDL_LockSurface
|
|
||||||
] when drop ;
|
|
||||||
|
|
||||||
: size-string ( font text -- w h )
|
|
||||||
>r lookup-font r> filter-nulls dup string-length 0 = [
|
|
||||||
drop TTF_FontHeight 0 swap
|
|
||||||
] [
|
|
||||||
<int-box> <int-box> [ TTF_SizeUNICODE drop ] 2keep
|
|
||||||
swap int-box-i swap int-box-i
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
global [ <namespace> fonts set ] bind
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,6 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: sdl-video
|
IN: sdl USING: alien kernel math ;
|
||||||
USING: alien kernel math ;
|
|
||||||
|
|
||||||
! These are the currently supported flags for the SDL_surface
|
! These are the currently supported flags for the SDL_surface
|
||||||
! Available for SDL_CreateRGBSurface() or SDL_SetVideoMode()
|
! Available for SDL_CreateRGBSurface() or SDL_SetVideoMode()
|
||||||
|
|
|
||||||
|
|
@ -1,33 +1,6 @@
|
||||||
! :folding=indent:collapseFolds=1:
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
! $Id$
|
IN: sdl USING: alien ;
|
||||||
!
|
|
||||||
! 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
|
|
||||||
USE: alien
|
|
||||||
USE: compiler
|
|
||||||
|
|
||||||
: SDL_INIT_TIMER HEX: 00000001 ;
|
: SDL_INIT_TIMER HEX: 00000001 ;
|
||||||
: SDL_INIT_AUDIO HEX: 00000010 ;
|
: SDL_INIT_AUDIO HEX: 00000010 ;
|
||||||
|
|
|
||||||
|
|
@ -1,26 +0,0 @@
|
||||||
IN: scratchpad
|
|
||||||
USE: sdl
|
|
||||||
USE: test
|
|
||||||
|
|
||||||
[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
|
|
||||||
|
|
||||||
[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
|
|
||||||
[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
|
|
||||||
|
|
||||||
[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
|
|
||||||
[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
|
|
||||||
|
|
||||||
[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
|
|
||||||
[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
|
|
||||||
|
|
||||||
[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
|
|
||||||
[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
|
|
||||||
|
|
||||||
[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
|
|
||||||
[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
|
|
||||||
|
|
||||||
[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
|
|
||||||
[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
|
|
||||||
|
|
||||||
[ 1 0 0 ] [ 1 1 1 hsv>rgb ] unit-test
|
|
||||||
[ 1/6 1/9 1/9 ] [ 1 1/3 1/6 hsv>rgb ] unit-test
|
|
||||||
|
|
@ -90,7 +90,6 @@ prettyprint stdio strings words vectors unparser ;
|
||||||
"inference"
|
"inference"
|
||||||
"dataflow"
|
"dataflow"
|
||||||
"interpreter"
|
"interpreter"
|
||||||
"hsv"
|
|
||||||
"alien"
|
"alien"
|
||||||
"line-editor"
|
"line-editor"
|
||||||
"gadgets"
|
"gadgets"
|
||||||
|
|
|
||||||
|
|
@ -103,34 +103,6 @@ M: plain-ellipse draw-shape ( ellipse -- )
|
||||||
>r surface get r> ellipse>screen bg rgb
|
>r surface get r> ellipse>screen bg rgb
|
||||||
filledEllipseColor ;
|
filledEllipseColor ;
|
||||||
|
|
||||||
! Strings are shapes too. This is somewhat of a hack and strings
|
|
||||||
! do not have x/y co-ordinates.
|
|
||||||
M: string shape-x drop 0 ;
|
|
||||||
M: string shape-y drop 0 ;
|
|
||||||
M: string shape-w
|
|
||||||
font get swap size-string ( h -) drop ;
|
|
||||||
|
|
||||||
M: string shape-h ( text -- h )
|
|
||||||
#! This is just the height of the current font.
|
|
||||||
drop font get lookup-font TTF_FontHeight ;
|
|
||||||
|
|
||||||
: filter-nulls ( str -- str )
|
|
||||||
"\0" over string-contains? [
|
|
||||||
[ dup CHAR: \0 = [ drop CHAR: \s ] when ] string-map
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
M: string draw-shape ( text -- )
|
|
||||||
dup string-length 0 = [
|
|
||||||
drop
|
|
||||||
] [
|
|
||||||
filter-nulls font get lookup-font swap
|
|
||||||
fg 3unlist make-color
|
|
||||||
bg 3unlist make-color
|
|
||||||
TTF_RenderUNICODE_Shaded
|
|
||||||
[ >r x get y get r> draw-surface ] keep
|
|
||||||
SDL_FreeSurface
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
! Clipping
|
! Clipping
|
||||||
|
|
||||||
SYMBOL: clip
|
SYMBOL: clip
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,94 @@
|
||||||
|
! Strings are shapes too. This is somewhat of a hack and strings
|
||||||
|
! do not have x/y co-ordinates.
|
||||||
|
IN: gadgets
|
||||||
|
USING: alien hashtables kernel lists namespaces sdl
|
||||||
|
sdl-ttf sdl-video streams strings ;
|
||||||
|
|
||||||
|
SYMBOL: fonts
|
||||||
|
|
||||||
|
: <font> ( name ptsize -- font )
|
||||||
|
>r resource-path swap cat2 r> TTF_OpenFont ;
|
||||||
|
|
||||||
|
SYMBOL: logical-fonts
|
||||||
|
|
||||||
|
: logical-font ( name -- name )
|
||||||
|
dup logical-fonts get hash dup [ nip ] [ drop ] ifte ;
|
||||||
|
|
||||||
|
global [
|
||||||
|
{{
|
||||||
|
[[ "Monospaced" "/fonts/VeraMono.ttf" ]]
|
||||||
|
[[ "Serif" "/fonts/VeraSe.ttf" ]]
|
||||||
|
[[ "Sans Serif" "/fonts/Vera.ttf" ]]
|
||||||
|
}} logical-fonts set
|
||||||
|
] bind
|
||||||
|
|
||||||
|
: (lookup-font) ( [[ name ptsize ]] -- font )
|
||||||
|
unswons logical-font swons dup get dup alien? [
|
||||||
|
dup alien-address 0 = [
|
||||||
|
drop f
|
||||||
|
] when
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: lookup-font ( [[ name ptsize ]] -- font )
|
||||||
|
fonts get [
|
||||||
|
(lookup-font) [
|
||||||
|
nip
|
||||||
|
] [
|
||||||
|
[ uncons <font> dup ] keep set
|
||||||
|
] ifte*
|
||||||
|
] bind ;
|
||||||
|
|
||||||
|
: make-rect ( x y w h -- rect )
|
||||||
|
<rect>
|
||||||
|
[ set-rect-h ] keep
|
||||||
|
[ set-rect-w ] keep
|
||||||
|
[ set-rect-y ] keep
|
||||||
|
[ set-rect-x ] keep ;
|
||||||
|
|
||||||
|
: surface-rect ( x y surface -- rect )
|
||||||
|
dup surface-w swap surface-h make-rect ;
|
||||||
|
|
||||||
|
: draw-surface ( x y surface -- )
|
||||||
|
surface get SDL_UnlockSurface
|
||||||
|
[
|
||||||
|
[ surface-rect ] keep swap surface get 0 0
|
||||||
|
] keep surface-rect swap rot SDL_UpperBlit drop
|
||||||
|
surface get dup must-lock-surface? [
|
||||||
|
SDL_LockSurface
|
||||||
|
] when drop ;
|
||||||
|
|
||||||
|
: size-string ( font text -- w h )
|
||||||
|
>r lookup-font r> filter-nulls dup string-length 0 = [
|
||||||
|
drop TTF_FontHeight 0 swap
|
||||||
|
] [
|
||||||
|
<int-box> <int-box> [ TTF_SizeUNICODE drop ] 2keep
|
||||||
|
swap int-box-i swap int-box-i
|
||||||
|
] ifte ;
|
||||||
|
|
||||||
|
global [ <namespace> fonts set ] bind
|
||||||
|
|
||||||
|
M: string shape-x drop 0 ;
|
||||||
|
M: string shape-y drop 0 ;
|
||||||
|
M: string shape-w
|
||||||
|
font get swap size-string ( h -) drop ;
|
||||||
|
|
||||||
|
M: string shape-h ( text -- h )
|
||||||
|
#! This is just the height of the current font.
|
||||||
|
drop font get lookup-font TTF_FontHeight ;
|
||||||
|
|
||||||
|
: filter-nulls ( str -- str )
|
||||||
|
"\0" over string-contains? [
|
||||||
|
[ dup CHAR: \0 = [ drop CHAR: \s ] when ] string-map
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
M: string draw-shape ( text -- )
|
||||||
|
dup string-length 0 = [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
filter-nulls font get lookup-font swap
|
||||||
|
fg 3unlist make-color
|
||||||
|
bg 3unlist make-color
|
||||||
|
TTF_RenderUNICODE_Shaded
|
||||||
|
[ >r x get y get r> draw-surface ] keep
|
||||||
|
SDL_FreeSurface
|
||||||
|
] ifte ;
|
||||||
Loading…
Reference in New Issue