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

started work on sdl-ttf binding, some-with? combinator

cvs
Slava Pestov 2005-01-20 02:01:47 +00:00
parent 2ecd3bad05
commit 21ce71c4a4
12 changed files with 147 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
library/assoc.factor
View File

@ -39,15 +39,11 @@ USE: kernel
: assoc* ( key alist -- [[ key value ]] )
#! Looks up the key in an alist. Push the key/value pair.
#! Most of the time you want to use assoc not assoc*.
dup [
2dup car car = [ nip car ] [ cdr assoc* ] ifte
] [
2drop f
] ifte ;
[ car = ] some-with? dup [ car ] when ;
: assoc ( key alist -- value )
#! Looks up the key in an alist.
assoc* dup [ cdr ] when ;
assoc* dup [ cdr ] when ;
: remove-assoc ( key alist -- alist )
#! Remove all key/value pairs with this key.
@ -70,11 +66,7 @@ USE: kernel
#! corresponding quotation, the value is popped off the
#! stack.
swap [
unswons rot assoc* dup [
cdr call
] [
2drop
] ifte
unswons rot assoc* dup [ cdr call ] [ 2drop ] ifte
] each-with ;
: 2cons ( car1 car2 cdr1 cdr2 -- cons1 cons2 )

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

@ -35,10 +35,6 @@ USE: namespaces
"Cold boot in progress..." print
! vocabularies get [
! "generic" off
! ] bind
[
"/library/generic/generic.factor"
"/library/generic/object.factor"
@ -137,6 +133,7 @@ USE: namespaces
"/library/sdl/sdl-gfx.factor"
"/library/sdl/sdl-keysym.factor"
"/library/sdl/sdl-keyboard.factor"
"/library/sdl/sdl-ttf.factor"
"/library/sdl/sdl-utils.factor"
"/library/sdl/hsv.factor"

2
library/combinators.factor
View File

@ -54,7 +54,7 @@ IN: kernel
#! If the condition is not f, execute the 'true' quotation,
#! with the condition on the stack. Otherwise, pop the
#! condition and execute the 'false' quotation.
pick [ drop call ] [ nip nip call ] ifte ; inline
pick [ drop call ] [ 2nip call ] ifte ; inline
: ?ifte ( default cond true false -- )
#! If cond is true, drop default and apply true

9
library/compiler/alien-types.factor
View File

@ -153,6 +153,15 @@ global [ <namespace> "c-types" set ] bind
"unbox_alien" "unboxer" set
] "void*" define-c-type
! FIXME
[
[ alien-4 ] "getter" set
[ set-alien-4 ] "setter" set
4 "width" set
"box_integer" "boxer" set
"unbox_integer" "unboxer" set
] "long" define-c-type
[
[ alien-4 ] "getter" set
[ set-alien-4 ] "setter" set

8
library/compiler/optimizer.factor
View File

@ -60,7 +60,7 @@ USE: vectors
: mentions-literal? ( literal list -- ? )
#! Does the given list of result objects refer to this
#! literal?
[ dupd value= ] some? nip ;
[ value= ] some-with? ;
: consumes-literal? ( literal node -- ? )
#! Does the dataflow node consume the literal?
@ -148,9 +148,7 @@ SYMBOL: branch-returns
] "calls-label" set-word-property
: calls-label? ( label list -- ? )
[
dupd "calls-label" [ 2drop f ] apply-dataflow
] some? nip ;
[ "calls-label" [ 2drop f ] apply-dataflow ] some-with? ;
#label [
[ node-param get ] bind calls-label?
@ -161,7 +159,7 @@ SYMBOL: branch-returns
] "calls-label" set-word-property
: branches-call-label? ( label list -- ? )
[ dupd calls-label? ] some? nip ;
[ calls-label? ] some-with? ;
\ ifte [
[ node-param get ] bind branches-call-label?

22
library/cons.factor
View File

@ -123,4 +123,24 @@ PREDICATE: general-list list ( list -- ? )
] ifte ; inline
: subset-with ( obj list quot -- list )
swap [ with rot ] subset nip nip ; inline
swap [ with rot ] subset 2nip ; inline
: some? ( list pred -- ? )
#! Apply predicate with stack effect ( elt -- ? ) to each
#! element, return remainder of list from first occurrence
#! where it is true, or return f.
over [
dup >r over >r >r car r> call [
r> r> drop
] [
r> cdr r> some?
] ifte
] [
2drop f
] ifte ; inline
: some-with? ( obj list pred -- ? )
#! Apply predicate with stack effect ( obj elt -- ? ) to
#! each element, return remainder of list from first
#! occurrence where it is true, or return f.
swap [ with rot ] some? 2nip ; inline

17
library/lists.factor
View File

@ -42,22 +42,9 @@ USE: math
: append ( [ list1 ] [ list2 ] -- [ list1 list2 ] )
over [ >r uncons r> append cons ] [ nip ] ifte ;
: some? ( list pred -- ? )
#! Apply predicate to each element ,return remainder of list
#! from first occurrence where it is true, or return f.
over [
dup >r over >r >r car r> call [
r> r> drop
] [
r> cdr r> some?
] ifte
] [
2drop f
] ifte ; inline
: contains? ( element list -- ? )
#! Test if a list contains an element.
[ over = ] some? >boolean nip ;
[ = ] some-with? >boolean ;
: partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
rot [ swapd cons ] [ >r cons r> ] ifte ;
@ -128,7 +115,7 @@ DEFER: tree-contains?
#! Push each element of a proper list in turn, and collect
#! return values of applying a quotation with effect
#! ( obj elt -- obj ) to each element into a new list.
swap [ with rot ] map nip nip ; inline
swap [ with rot ] map 2nip ; inline
: remove ( obj list -- list )
#! Remove all occurrences of the object from the list.

2
library/random.factor
View File

@ -37,7 +37,7 @@ USE: math
3dup - + 1 < [
2drop (random-int) 2dup swap mod (random-int-0)
] [
nip nip
2nip
] ifte ;
: random-int-0 ( max -- n )

100
library/sdl/sdl-ttf.factor Normal file
View File

@ -0,0 +1,100 @@
! :folding=indent:collapseFolds=1:sidekick.parser=none:
! $Id$
!
! Copyright (C) 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.
IN: sdl-ttf
USE: alien
: UNICODE_BOM_NATIVE HEX: FEFF ;
: UNICODE_BOM_SWAPPED HEX: FFFE ;
: TTF_ByteSwappedUNICODE ( swapped -- )
"void" "sdl-ttf" "TTF_ByteSwappedUNICODE" [ "int" ] alien-invoke ;
: TTF_Init ( swapped -- )
"void" "sdl-ttf" "TTF_Init" [ ] alien-invoke ;
: TTF_OpenFont ( file ptsize -- font )
"void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" ] alien-invoke ;
: TTF_OpenFontIndex ( file ptsize index -- font )
"void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" "long" ] alien-invoke ;
: TTF_STYLE_NORMAL HEX: 00 ;
: TTF_STYLE_BOLD HEX: 01 ;
: TTF_STYLE_ITALIC HEX: 02 ;
: TTF_STYLE_UNDERLINE HEX: 04 ;
: TTF_GetFontStyle ( font -- style )
"int" "sdl-ttf" "TTF_GetFontStyle" [ "void*" ] alien-invoke ;
: TTF_SetFontStyle ( font style -- )
"void" "sdl-ttf" "TTF_SetFontStyle" [ "void*" "int" ] alien-invoke ;
: TTF_FontHeight ( font -- n )
"int" "sdl-ttf" "TTF_FontHeight" [ "void*" ] alien-invoke ;
: TTF_FontAscent ( font -- n )
"int" "sdl-ttf" "TTF_FontAscent" [ "void*" ] alien-invoke ;
: TTF_FontDescent ( font -- n )
"int" "sdl-ttf" "TTF_FontDescent" [ "void*" ] alien-invoke ;
: TTF_FontLineSkip ( font -- n )
"int" "sdl-ttf" "TTF_FontLineSkip" [ "void*" ] alien-invoke ;
: TTF_FontFaces ( font -- n )
"long" "sdl-ttf" "TTF_FontFaces" [ "void*" ] alien-invoke ;
: TTF_FontFaceIsFixedWidth ( font -- ? )
"bool" "sdl-ttf" "TTF_FontFaceIsFixedWidth" [ "void*" ] alien-invoke ;
: TTF_FontFaceFamilyName ( font -- n )
"char*" "sdl-ttf" "TTF_FontFaceFamilyName" [ "void*" ] alien-invoke ;
: TTF_FontFaceStyleName ( font -- n )
"char*" "sdl-ttf" "TTF_FontFaceStyleName" [ "void*" ] alien-invoke ;
: TTF_RenderText_Solid ( font text fg bg -- surface )
"surface*" "sdl-ttf" "TTF_RenderText_Solid" [ "void*" "char*" "int" "int" ] alien-invoke ;
: TTF_RenderGlyph_Shaded ( font text fg bg -- surface )
"surface*" "sdl-ttf" "TTF_RenderGlyph_Shaded" [ "void*" "ushort" "int" "int" ] alien-invoke ;
: TTF_RenderText_Blended ( font text fg -- surface )
"surface*" "sdl-ttf" "TTF_RenderText_Blended" [ "void*" "ushort" "int" "int" ] alien-invoke ;
: TTF_RenderGlyph_Blended ( font text fg -- surface )
"surface*" "sdl-ttf" "TTF_RenderGlyph_Blended" [ "void*" "ushort" "int" ] alien-invoke ;
: TTF_CloseFont ( font -- )
"void" "sdl-ttf" "TTF_CloseFont" [ "void*" ] alien-invoke ;
: TTF_Quit ( -- )
"void" "sdl-ttf" "TTF_CloseFont" [ ] alien-invoke ;
: TTF_WasInit ( -- ? )
"bool" "sdl-ttf" "TTF_WasInit" [ ] alien-invoke ;

1
library/stack.factor
View File

@ -36,6 +36,7 @@ IN: kernel
: dupd ( x y -- x x y ) >r dup r> ; inline
: swapd ( x y z -- y x z ) >r swap r> ; inline
: nip ( x y -- y ) swap drop ; inline
: 2nip ( x y z -- z ) >r drop drop r> ; inline
: tuck ( x y -- y x y ) dup >r swap r> ; inline
: clear ( -- )

6
library/test/dataflow.factor
View File

@ -15,19 +15,19 @@ USE: generic
: dataflow-contains-op? ( object list -- ? )
#! Check if some dataflow node contains a given operation.
[ dupd node-op swap hash = ] some? nip ;
[ node-op swap hash = ] some-with? ;
: dataflow-contains-param? ( object list -- ? )
#! Check if some dataflow node contains a given operation.
[
dupd [
[
node-op get #label = [
node-param get dataflow-contains-param?
] [
node-param get =
] ifte
] bind
] some? nip ;
] some-with? ;
[ t ] [
\ + [ 2 2 + ] dataflow dataflow-contains-param? >boolean

4
library/vectors.factor
View File

@ -126,7 +126,7 @@ BUILTIN: vector 11
#! first two in a pair.
over vector-length over vector-length min [
pick pick >r over >r vector-nth r> r> vector-nth cons
] vector-project nip nip ;
] vector-project 2nip ;
: vector-clone ( vector -- vector )
#! Shallow copy of a vector.
@ -172,7 +172,7 @@ M: vector hashcode ( vec -- n )
#! index upwards.
2dup vector-length swap - [
pick + over vector-nth
] project nip nip ;
] project 2nip ;
: vector-tail* ( n vector -- list )
#! Unlike vector-tail, n is an index from the end of the