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

diff --git a/library/assoc.factor b/library/assoc.factor
index 6815f6bb6fbbae99dff6d3c6bf226299bdff1995..e3da70d8da1d6f7e8bb45ba93da24365c3b36690 100644 (file)
--- a/library/assoc.factor
+++ b/library/assoc.factor
@@ -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 )

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index dba461a37a3ea60829d611900f75fb1cbe0ef99e..dd4addbadd174f8dba067f00299b842b3df3a938 100644 (file)
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -35,10 +35,6 @@ USE: namespaces
 \r
 "Cold boot in progress..." print\r
 \r
-! vocabularies get [\r
-!     "generic" off\r
-! ] bind\r
-\r
 [\r
     "/library/generic/generic.factor"\r
     "/library/generic/object.factor"\r
@@ -137,6 +133,7 @@ USE: namespaces
     "/library/sdl/sdl-gfx.factor"\r
     "/library/sdl/sdl-keysym.factor"\r
     "/library/sdl/sdl-keyboard.factor"\r
+    "/library/sdl/sdl-ttf.factor"\r
     "/library/sdl/sdl-utils.factor"\r
     "/library/sdl/hsv.factor"\r
 \r

diff --git a/library/combinators.factor b/library/combinators.factor
index 1620c6452ab4a67b36f0f0bc7ac1aeee4e3f8ebe..6c0e912e8e16d30ece96030701a832e5fe7d0ae9 100644 (file)
--- a/library/combinators.factor
+++ b/library/combinators.factor
@@ -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

diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor
index 2bdf5d8f538af0d68cf51eddbd88fec76b39c64d..1aad3c6033f68177aed84047ba1d05f33fc433eb 100644 (file)
--- a/library/compiler/alien-types.factor
+++ b/library/compiler/alien-types.factor
@@ -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

diff --git a/library/compiler/optimizer.factor b/library/compiler/optimizer.factor
index 88b7847174916cece51e847a6443bd283efa731d..9d3e0b6f00029b3e86b7d9960fa54b873c9cc50e 100644 (file)
--- a/library/compiler/optimizer.factor
+++ b/library/compiler/optimizer.factor
@@ -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?

diff --git a/library/cons.factor b/library/cons.factor
index 95243bad29d0a570bfe05dbd09571c9c71fad4f5..d3af62c20327b2593d8f02de4f0af838f4c93d2d 100644 (file)
--- a/library/cons.factor
+++ b/library/cons.factor
@@ -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

diff --git a/library/lists.factor b/library/lists.factor
index 45667f92c994f7f857de13d18b7fc0c7c45e6475..cfe95b7db12b4caafbda3f686b17fa820373bb4a 100644 (file)
--- a/library/lists.factor
+++ b/library/lists.factor
@@ -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.

diff --git a/library/random.factor b/library/random.factor
index 312c45a75feb670730bf83184f902e85aefbac20..b9ea85345c013e9319dcba15157ae57bd2d97c30 100644 (file)
--- a/library/random.factor
+++ b/library/random.factor
@@ -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 )

diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor
new file mode 100644 (file)
index 0000000..0683171
--- /dev/null
+++ b/library/sdl/sdl-ttf.factor
@@ -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 ;

diff --git a/library/stack.factor b/library/stack.factor
index 19dfc2d7d4dabe44cc623b18347d9ac0ebc9f71e..217ddf716982f0c74bcffe7f74d3df6ad00bbd1a 100644 (file)
--- a/library/stack.factor
+++ b/library/stack.factor
@@ -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 ( -- )

diff --git a/library/test/dataflow.factor b/library/test/dataflow.factor
index dcd4727610361eddcf8e38837a74edd1c6f58df4..0a769c7d73591b46b56c91a8e980315ede94b50a 100644 (file)
--- a/library/test/dataflow.factor
+++ b/library/test/dataflow.factor
@@ -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

diff --git a/library/vectors.factor b/library/vectors.factor
index a2cf2c11acbb6be1279caf3cf8fe3bb0d173ba99..2ef7d37c99038986ccfafd7721655e6eecf4a001 100644 (file)
--- a/library/vectors.factor
+++ b/library/vectors.factor
@@ -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