From 84b5ace86378d51ea4d6c9ad40aeaff1b8a0e0b5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 28 Mar 2009 22:26:49 -0500 Subject: [PATCH 01/73] alien.destructors: ignore any output values from disposal word --- basis/alien/destructors/destructors.factor | 5 +++-- basis/combinators/smart/smart.factor | 3 +++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/basis/alien/destructors/destructors.factor b/basis/alien/destructors/destructors.factor index 1b6022d3b7..1c5c975fe6 100644 --- a/basis/alien/destructors/destructors.factor +++ b/basis/alien/destructors/destructors.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: functors destructors accessors kernel parser words ; +USING: functors destructors accessors kernel parser words +combinators.smart ; IN: alien.destructors SLOT: alien @@ -18,7 +19,7 @@ TUPLE: F-destructor alien disposed ; : ( alien -- destructor ) f F-destructor boa ; inline -M: F-destructor dispose* alien>> F ; +M: F-destructor dispose* [ alien>> F ] drop-outputs ; : &F ( alien -- alien ) dup &dispose drop ; inline diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index e7bdd75ced..aa7960539c 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -4,6 +4,9 @@ USING: accessors fry generalizations kernel macros math.order stack-checker math ; IN: combinators.smart +MACRO: drop-outputs ( quot -- quot' ) + dup infer out>> '[ @ _ ndrop ] ; + MACRO: output>sequence ( quot exemplar -- newquot ) [ dup infer out>> ] dip '[ @ _ _ nsequence ] ; From a58ce33bb3e8bf00e1c8f4196458c9ed4af97420 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 28 Mar 2009 22:27:18 -0500 Subject: [PATCH 02/73] Split off some code from ui.backend.windows into windows.offscreen --- basis/ui/backend/windows/windows.factor | 50 ++++++------------------ basis/windows/gdi32/gdi32.factor | 6 ++- basis/windows/offscreen/authors.txt | 1 + basis/windows/offscreen/offscreen.factor | 47 ++++++++++++++++++++++ extra/ui/offscreen/offscreen.factor | 4 +- extra/ui/offscreen/tags.txt | 1 - 6 files changed, 67 insertions(+), 42 deletions(-) create mode 100644 basis/windows/offscreen/authors.txt create mode 100644 basis/windows/offscreen/offscreen.factor diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 80dd313e85..12ce2bed80 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -1,16 +1,16 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! Portions copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types alien.strings arrays assocs ui -ui.private ui.gadgets ui.gadgets.private ui.backend -ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io -kernel math math.vectors namespaces make sequences strings -vectors words windows.kernel32 windows.gdi32 windows.user32 -windows.opengl32 windows.messages windows.types windows.nt -windows threads libc combinators fry combinators.short-circuit -continuations command-line shuffle opengl ui.render ascii -math.bitwise locals accessors math.rectangles math.order ascii -calendar io.encodings.utf16n ; +USING: alien alien.c-types alien.strings arrays assocs ui ui.private +ui.gadgets ui.gadgets.private ui.backend ui.clipboards +ui.gadgets.worlds ui.gestures ui.event-loop io kernel math +math.vectors namespaces make sequences strings vectors words +windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 +windows.messages windows.types windows.offscreen windows.nt windows +threads libc combinators fry combinators.short-circuit continuations +command-line shuffle opengl ui.render ascii math.bitwise locals +accessors math.rectangles math.order ascii calendar +io.encodings.utf16n ; IN: ui.backend.windows SINGLETON: windows-ui-backend @@ -501,35 +501,12 @@ M: windows-ui-backend (open-window) ( world -- ) hWnd>> show-window ; M: win-base select-gl-context ( handle -- ) - [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f + [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f GdiFlush drop ; M: win-base flush-gl-context ( handle -- ) hDC>> SwapBuffers win32-error=0/f ; -: (bitmap-info) ( dim -- BITMAPINFO ) - "BITMAPINFO" [ - BITMAPINFO-bmiHeader { - [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ] - [ [ first ] dip set-BITMAPINFOHEADER-biWidth ] - [ [ second ] dip set-BITMAPINFOHEADER-biHeight ] - [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ] - [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ] - [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ] - [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ] - [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ] - [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ] - [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ] - [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ] - } 2cleave - ] keep ; - -: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits ) - f CreateCompatibleDC - dup rot (bitmap-info) DIB_RGB_COLORS f - [ f 0 CreateDIBSection ] keep *void* - [ 2dup SelectObject drop ] dip ; - : setup-offscreen-gl ( dim -- hDC hRC hBitmap bits ) make-offscreen-dc-and-bitmap [ [ dup offscreen-pfd-dwFlags setup-pixel-format ] @@ -548,13 +525,12 @@ M: windows-ui-backend (close-offscreen-buffer) ( handle -- ) ! each pixel; it's left as zero : (make-opaque) ( byte-array -- byte-array' ) - [ length 4 / ] + [ length 4 /i ] [ '[ 255 swap 4 * 3 + _ set-nth ] each ] [ ] tri ; : (opaque-pixels) ( world -- pixels ) - [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi - memory>byte-array (make-opaque) ; + [ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ; M: windows-ui-backend offscreen-pixels ( world -- alien w h ) [ (opaque-pixels) ] [ dim>> first2 ] bi ; diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 077adf1961..2281255a4f 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1,7 +1,6 @@ -! FUNCTION: AbortDoc ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax kernel windows.types ; +USING: alien alien.syntax alien.destructors kernel windows.types ; IN: windows.gdi32 ! Stock Logical Objects @@ -36,6 +35,7 @@ CONSTANT: DIB_PAL_COLORS 1 LIBRARY: gdi32 +! FUNCTION: AbortDoc ! FUNCTION: AbortPath ! FUNCTION: AddFontMemResourceEx ! FUNCTION: AddFontResourceA @@ -178,9 +178,11 @@ FUNCTION: HRGN CreateRectRgn ( int x, int y, int w, int h ) ; ! FUNCTION: DdEntry9 ! FUNCTION: DeleteColorSpace FUNCTION: BOOL DeleteDC ( HDC hdc ) ; +DESTRUCTOR: DeleteDC ! FUNCTION: DeleteEnhMetaFile ! FUNCTION: DeleteMetaFile FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ; +DESTRUCTOR: DeleteObject ! FUNCTION: DescribePixelFormat ! FUNCTION: DeviceCapabilitiesExA ! FUNCTION: DeviceCapabilitiesExW diff --git a/basis/windows/offscreen/authors.txt b/basis/windows/offscreen/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/windows/offscreen/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/windows/offscreen/offscreen.factor b/basis/windows/offscreen/offscreen.factor new file mode 100644 index 0000000000..4eee68c37a --- /dev/null +++ b/basis/windows/offscreen/offscreen.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2009 Joe Groff, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types kernel combinators sequences +math windows.gdi32 windows.types images destructors +accessors fry ; +IN: windows.offscreen + +: (bitmap-info) ( dim -- BITMAPINFO ) + "BITMAPINFO" [ + BITMAPINFO-bmiHeader { + [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ] + [ [ first ] dip set-BITMAPINFOHEADER-biWidth ] + [ [ second ] dip set-BITMAPINFOHEADER-biHeight ] + [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ] + [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ] + [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ] + [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ] + [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ] + [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ] + [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ] + [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ] + } 2cleave + ] keep ; + +: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits ) + f CreateCompatibleDC + [ nip ] + [ + swap (bitmap-info) DIB_RGB_COLORS f + [ f 0 CreateDIBSection ] keep *void* + ] 2bi + [ 2dup SelectObject drop ] dip ; + +: bitmap>byte-array ( bits dim -- byte-array ) + product 4 * memory>byte-array ; + +: bitmap>image ( bits dim -- image ) + [ bitmap>byte-array ] keep + swap >>dim swap >>bitmap XBGR >>component-order ; + +: make-bitmap-image ( dim quot: ( hDC -- ) -- image ) + '[ + [ + make-offscreen-dc-and-bitmap + [ &DeleteDC @ ] [ &DeleteObject drop ] [ ] tri* + ] keep bitmap>byte-array + ] with-destructors ; inline \ No newline at end of file diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index cf9370ed7f..f0b81ccacd 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,7 +1,7 @@ ! (c) 2008 Joe Groff, see license for details USING: accessors continuations images.bitmap kernel math -sequences ui.gadgets ui.gadgets.worlds ui ui.backend -destructors ; +sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds +ui.private ui ui.backend destructors ; IN: ui.offscreen TUPLE: offscreen-world < world ; diff --git a/extra/ui/offscreen/tags.txt b/extra/ui/offscreen/tags.txt index b796ebde91..46f6dcd8de 100644 --- a/extra/ui/offscreen/tags.txt +++ b/extra/ui/offscreen/tags.txt @@ -1,3 +1,2 @@ -unportable ui graphics From cf87e20a30af3479fd0ce2e09b77701775f3699f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 28 Mar 2009 22:27:37 -0500 Subject: [PATCH 03/73] Uniscribe text rendering work in progress --- basis/windows/uniscribe/authors.txt | 1 + basis/windows/uniscribe/uniscribe.factor | 65 ++++++++++++++++++++++++ basis/windows/usp10/usp10.factor | 4 +- 3 files changed, 69 insertions(+), 1 deletion(-) create mode 100644 basis/windows/uniscribe/authors.txt create mode 100644 basis/windows/uniscribe/uniscribe.factor diff --git a/basis/windows/uniscribe/authors.txt b/basis/windows/uniscribe/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/windows/uniscribe/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor new file mode 100644 index 0000000000..5d24601555 --- /dev/null +++ b/basis/windows/uniscribe/uniscribe.factor @@ -0,0 +1,65 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences io.encodings.string io.encodings.utf16n +accessors arrays destructors alien.c-types windows windows.usp10 +windows.offscreen ; +IN: windows.uniscribe + +TUPLE: script-string pssa size image ; + +: make-script-string ( dc string -- script-string ) + [ utf16n encode ] ! pString + [ length ] bi ! cString + dup 1.5 * 16 + ! cGlyphs -- MSDN says this is "recommended size" + -1 ! iCharset -- Unicode + SSA_GLYPHS ! dwFlags + ... ! iReqWidth + f ! psControl + f ! psState + f ! piDx + f ! pTabdef + ... ! pbInClass + f ! pssa + [ ScriptStringAnalyse ] keep + [ win32-error=0/f ] [ |ScriptStringFree ] bi* ; + +: draw-script-string ( script-string -- bitmap ) + ! ssa + 0 ! iX + 0 ! iY + ETO_OPAQUE ! uOptions ... ???? + f ! prc + 0 ! iMinSel + 0 ! iMaxSel + f ! fDisabled + ScriptStringOut ; + +: ( string -- script-string ) + [ + ... dim ... [ + make-script-string |ScriptStringFree + [ ] + [ draw-script-string ] + [ + ScriptString_pSize + dup win32-error=0/f + [ SIZE-cx ] [ SIZE-cy ] bi 2array + ] tri + ] make-bitmap-image + script-string boa + ] with-destructors ; + +M: script-string dispose* pssa>> ScriptStringFree win32-error=0/f ; + +: line-offset>x ( offset script-string -- x ) + pssa>> ! ssa + swap ! icp + ... ! fTrailing + 0 [ ScriptStringCPtoX win32-error=0/f ] keep *int ; + +: line-x>offset ( x script-string -- offset trailing ) + pssa>> ! ssa + swap ! iX + 0 ! pCh + 0 ! piTrailing + [ ScriptStringXtoCP win32-error=0/f ] 2keep [ *int ] bi@ ; \ No newline at end of file diff --git a/basis/windows/usp10/usp10.factor b/basis/windows/usp10/usp10.factor index 64e5a60019..50fa98996c 100755 --- a/basis/windows/usp10/usp10.factor +++ b/basis/windows/usp10/usp10.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax alien.destructors ; IN: windows.usp10 LIBRARY: usp10 @@ -262,6 +262,8 @@ FUNCTION: HRESULT ScriptStringFree ( SCRIPT_STRING_ANALYSIS* pssa ) ; +DESTRUCTOR: ScriptStringFree + FUNCTION: SIZE* ScriptString_pSize ( SCRIPT_STRING_ANALYSIS ssa ) ; FUNCTION: int* ScriptString_pcOutChars ( SCRIPT_STRING_ANALYSIS ssa ) ; From 6399f4bc1a297d13285c108c98f20c98660ae12f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 2 Apr 2009 11:39:18 -0500 Subject: [PATCH 04/73] handle defines better, save all #if/#elif/#else/#pragma/#include_next. next step: tokenizing and macro replacement --- .../c/preprocessor/preprocessor-tests.factor | 12 +++- extra/c/preprocessor/preprocessor.factor | 62 +++++++++++++++---- 2 files changed, 61 insertions(+), 13 deletions(-) diff --git a/extra/c/preprocessor/preprocessor-tests.factor b/extra/c/preprocessor/preprocessor-tests.factor index d86b85a1b1..ba0531dfe7 100644 --- a/extra/c/preprocessor/preprocessor-tests.factor +++ b/extra/c/preprocessor/preprocessor-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test c.preprocessor kernel accessors ; +USING: tools.test c.preprocessor kernel accessors multiline ; IN: c.preprocessor.tests [ "vocab:c/tests/test1/test1.c" start-preprocess-file ] @@ -9,8 +9,18 @@ IN: c.preprocessor.tests [ "yo\n\n\n\nyo4\n" ] [ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test +/* [ "vocab:c/tests/test3/test3.c" start-preprocess-file ] [ "\"BOO\"" = ] must-fail-with +*/ [ V{ "\"omg\"" "\"lol\"" } ] [ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test + + +/* +f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1); +f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1); +int i[] = { 1, 23, 4, 5, }; +char c[2][6] = { "hello", "" }; +*/ diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor index 89292eb74b..f7cd10a0e9 100644 --- a/extra/c/preprocessor/preprocessor.factor +++ b/extra/c/preprocessor/preprocessor.factor @@ -3,24 +3,41 @@ USING: html.parser.state io io.encodings.utf8 io.files io.streams.string kernel combinators accessors io.pathnames fry sequences arrays locals namespaces io.directories -assocs math splitting make ; +assocs math splitting make unicode.categories +combinators.short-circuit ; IN: c.preprocessor : initial-library-paths ( -- seq ) V{ "/usr/include" } clone ; +: initial-symbol-table ( -- hashtable ) + H{ + { "__APPLE__" "" } + { "__amd64__" "" } + { "__x86_64__" "" } + } clone ; + TUPLE: preprocessor-state library-paths symbol-table include-nesting include-nesting-max processing-disabled? -ifdef-nesting warnings ; +ifdef-nesting warnings errors +pragmas +include-nexts +ifs elifs elses ; : ( -- preprocessor-state ) preprocessor-state new initial-library-paths >>library-paths - H{ } clone >>symbol-table + initial-symbol-table >>symbol-table 0 >>include-nesting 200 >>include-nesting-max 0 >>ifdef-nesting - V{ } clone >>warnings ; + V{ } clone >>warnings + V{ } clone >>errors + V{ } clone >>pragmas + V{ } clone >>include-nexts + V{ } clone >>ifs + V{ } clone >>elifs + V{ } clone >>elses ; DEFER: preprocess-file @@ -64,8 +81,13 @@ ERROR: header-file-missing path ; : readlns ( -- string ) [ (readlns) ] { } make concat ; +: take-define-identifier ( state-parser -- string ) + skip-whitespace + [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ; + : handle-define ( preprocessor-state state-parser -- ) - [ take-token ] [ take-rest ] bi + [ take-define-identifier ] + [ skip-whitespace take-rest ] bi "\\" ?tail [ readlns append ] when spin symbol-table>> set-at ; @@ -86,9 +108,25 @@ ERROR: header-file-missing path ; : handle-endif ( preprocessor-state state-parser -- ) drop [ 1 - ] change-ifdef-nesting drop ; +: handle-if ( preprocessor-state state-parser -- ) + [ [ 1 + ] change-ifdef-nesting ] dip + skip-whitespace take-rest swap ifs>> push ; + +: handle-elif ( preprocessor-state state-parser -- ) + skip-whitespace take-rest swap elifs>> push ; + +: handle-else ( preprocessor-state state-parser -- ) + skip-whitespace take-rest swap elses>> push ; + +: handle-pragma ( preprocessor-state state-parser -- ) + skip-whitespace take-rest swap pragmas>> push ; + +: handle-include-next ( preprocessor-state state-parser -- ) + skip-whitespace take-rest swap include-nexts>> push ; + : handle-error ( preprocessor-state state-parser -- ) - skip-whitespace - nip take-rest throw ; + skip-whitespace take-rest swap errors>> push ; + ! nip take-rest throw ; : handle-warning ( preprocessor-state state-parser -- ) skip-whitespace @@ -104,11 +142,11 @@ ERROR: header-file-missing path ; { "ifdef" [ handle-ifdef ] } { "ifndef" [ handle-ifndef ] } { "endif" [ handle-endif ] } - { "if" [ 2drop ] } - { "elif" [ 2drop ] } - { "else" [ 2drop ] } - { "pragma" [ 2drop ] } - { "include_next" [ 2drop ] } + { "if" [ handle-if ] } + { "elif" [ handle-elif ] } + { "else" [ handle-else ] } + { "pragma" [ handle-pragma ] } + { "include_next" [ handle-include-next ] } [ unknown-c-preprocessor ] } case ; From e841308bf6af017ba9aadbdd276cf1ad7ecfa99c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 2 Apr 2009 11:40:15 -0500 Subject: [PATCH 05/73] adding some preprocessor test files --- extra/c/tests/test5/test5.c | 3 +++ extra/c/tests/test6/test6.c | 1 + extra/c/tests/test7/test7.c | 19 +++++++++++++++++++ extra/c/tests/test8/test8.c | 15 +++++++++++++++ extra/c/tests/test9/test9.c | 4 ++++ 5 files changed, 42 insertions(+) create mode 100644 extra/c/tests/test5/test5.c create mode 100644 extra/c/tests/test6/test6.c create mode 100644 extra/c/tests/test7/test7.c create mode 100644 extra/c/tests/test8/test8.c create mode 100644 extra/c/tests/test9/test9.c diff --git a/extra/c/tests/test5/test5.c b/extra/c/tests/test5/test5.c new file mode 100644 index 0000000000..4c169640ef --- /dev/null +++ b/extra/c/tests/test5/test5.c @@ -0,0 +1,3 @@ +#define TABSIZE 100 + +int table[TABSIZE]; diff --git a/extra/c/tests/test6/test6.c b/extra/c/tests/test6/test6.c new file mode 100644 index 0000000000..3b0353a518 --- /dev/null +++ b/extra/c/tests/test6/test6.c @@ -0,0 +1 @@ +#define max(a, b) ((a) > (b) ? (a) : (b)) diff --git a/extra/c/tests/test7/test7.c b/extra/c/tests/test7/test7.c new file mode 100644 index 0000000000..4d5e66ba24 --- /dev/null +++ b/extra/c/tests/test7/test7.c @@ -0,0 +1,19 @@ +#define x 3 +#define f(a) f(x * (a)) +#undef x +#define x 2 +#define g f +#define z z[0] +#define h g(~ +#define m(a) a(w) +#define w 0,1 +#define t(a) a +#define p() int +#define q(x) x +#define r(x,y) x ## y +#define str(x) # x +f(y+1) + f(f(z)) % t(t(g)(0) + t)(1); +g(x+(3,4)-w) | h 5) & m +(f)^m(m); +p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) }; +char c[2][6] = { str(hello), str() }; diff --git a/extra/c/tests/test8/test8.c b/extra/c/tests/test8/test8.c new file mode 100644 index 0000000000..bc1e27348d --- /dev/null +++ b/extra/c/tests/test8/test8.c @@ -0,0 +1,15 @@ +#define str(s) #s +#define xstr(s) str(s) +#define debug(s, t) printf("x" # s "= %d, x" # t "= %s", \ +x ## s, x ## t) +#define INCFILE(n) vers ## n +#define glue(a, b) a## b +#define xglue(a, b) glue(a, b) +#define HIGHLOW "hello" +#define LOW LOW ", world" +debug(1, 2); +fputs(str(strncmp("abc\0d", "abc", '\4') //this goes away +== 0) str(: @\n), s); +#include xstr(INCFILE(2).h) +glue(HIGH, LOW); +xglue(HIGH, LOW) diff --git a/extra/c/tests/test9/test9.c b/extra/c/tests/test9/test9.c new file mode 100644 index 0000000000..86940cfbea --- /dev/null +++ b/extra/c/tests/test9/test9.c @@ -0,0 +1,4 @@ +#define t(x,y,z) x ## y ## z +int j[] = { t(1,2,3), t(,4,5), t(6,,7), t(8,9,), +t(10,,), t(,11,), t(,,12), t(,,) }; + From 5a9dc867745bc68e902773459ace0d25c2228e26 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 2 Apr 2009 11:42:10 -0500 Subject: [PATCH 06/73] fix typo --- vm/platform.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/platform.h b/vm/platform.h index 21336e88bb..70804542b4 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -96,7 +96,7 @@ #if defined(FACTOR_X86) #include "os-solaris-x86.32.h" #elif defined(FACTOR_AMD64) - #incluide "os-solaris-x86.64.h" + #include "os-solaris-x86.64.h" #else #error "Unsupported Solaris flavor" #endif From 070e5ef9bf3de5eab531f212a2382437c8b683a0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 2 Apr 2009 12:25:41 -0500 Subject: [PATCH 07/73] check in more test cases for later --- extra/c/tests/test10/test10.c | 3 +++ extra/c/tests/test11/foo.h | 1 + extra/c/tests/test11/test11.c | 2 ++ extra/c/tests/test12/test12.c | 3 +++ extra/c/tests/test13/test13.c | 2 ++ extra/c/tests/test14/test14.c | 15 +++++++++++++++ 6 files changed, 26 insertions(+) create mode 100644 extra/c/tests/test10/test10.c create mode 100644 extra/c/tests/test11/foo.h create mode 100644 extra/c/tests/test11/test11.c create mode 100644 extra/c/tests/test12/test12.c create mode 100644 extra/c/tests/test13/test13.c create mode 100644 extra/c/tests/test14/test14.c diff --git a/extra/c/tests/test10/test10.c b/extra/c/tests/test10/test10.c new file mode 100644 index 0000000000..7f38e70d73 --- /dev/null +++ b/extra/c/tests/test10/test10.c @@ -0,0 +1,3 @@ +/* +# lol +*/ diff --git a/extra/c/tests/test11/foo.h b/extra/c/tests/test11/foo.h new file mode 100644 index 0000000000..381b7535a0 --- /dev/null +++ b/extra/c/tests/test11/foo.h @@ -0,0 +1 @@ +foo.h ftw diff --git a/extra/c/tests/test11/test11.c b/extra/c/tests/test11/test11.c new file mode 100644 index 0000000000..1b05118b01 --- /dev/null +++ b/extra/c/tests/test11/test11.c @@ -0,0 +1,2 @@ +#define FOO_H "foo.h" +#include FOO_H diff --git a/extra/c/tests/test12/test12.c b/extra/c/tests/test12/test12.c new file mode 100644 index 0000000000..2da127bce0 --- /dev/null +++ b/extra/c/tests/test12/test12.c @@ -0,0 +1,3 @@ +#if 4 > (5 - 4++) +#error "Umm" +#endif diff --git a/extra/c/tests/test13/test13.c b/extra/c/tests/test13/test13.c new file mode 100644 index 0000000000..13c48ff6d0 --- /dev/null +++ b/extra/c/tests/test13/test13.c @@ -0,0 +1,2 @@ +#if 10 +#error "Umm" diff --git a/extra/c/tests/test14/test14.c b/extra/c/tests/test14/test14.c new file mode 100644 index 0000000000..1697ea1697 --- /dev/null +++ b/extra/c/tests/test14/test14.c @@ -0,0 +1,15 @@ +#if 4 > (1 + 2) +good +#endif + +#if 4 > 1 + 2 +good +#endif + +#if (4 > 1) - 1 +bad +#endif + +#if (4 > 1) - 2 +good +#endif From 9c3054c84a5316e538a7345e491e0f935559ca9c Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Thu, 2 Apr 2009 13:05:26 -0500 Subject: [PATCH 08/73] More progress on Uniscribe --- README.txt | 6 - basis/alien/destructors/destructors.factor | 5 +- .../images/normalization/normalization.factor | 12 + basis/opengl/textures/textures.factor | 1 + basis/ui/backend/windows/windows.factor | 7 +- basis/ui/text/core-text/core-text.factor | 3 - basis/ui/text/pango/pango.factor | 3 - basis/ui/text/text-tests.factor | 20 +- basis/ui/text/text.factor | 11 +- basis/ui/text/uniscribe/uniscribe.factor | 41 + basis/windows/fonts/fonts.factor | 37 + basis/windows/gdi32/gdi32.factor | 1311 ++++++++++++++++- .../windows/offscreen/offscreen-tests.factor | 5 + basis/windows/offscreen/offscreen.factor | 30 +- basis/windows/types/types.factor | 64 +- basis/windows/uniscribe/uniscribe.factor | 100 +- 16 files changed, 1536 insertions(+), 120 deletions(-) mode change 100644 => 100755 basis/alien/destructors/destructors.factor mode change 100644 => 100755 basis/images/normalization/normalization.factor mode change 100644 => 100755 basis/opengl/textures/textures.factor mode change 100644 => 100755 basis/ui/text/core-text/core-text.factor mode change 100644 => 100755 basis/ui/text/text-tests.factor mode change 100644 => 100755 basis/ui/text/text.factor create mode 100755 basis/ui/text/uniscribe/uniscribe.factor create mode 100755 basis/windows/fonts/fonts.factor create mode 100755 basis/windows/offscreen/offscreen-tests.factor mode change 100644 => 100755 basis/windows/offscreen/offscreen.factor mode change 100644 => 100755 basis/windows/uniscribe/uniscribe.factor diff --git a/README.txt b/README.txt index bd9da0ab2b..c5d53de842 100755 --- a/README.txt +++ b/README.txt @@ -113,12 +113,6 @@ the command prompt using the console application: factor.com -i=boot..image -Before bootstrapping, you will need to download the DLLs for the Pango -text rendering library. The required DLLs are listed in -build-support/dlls.txt and are available from the following location: - - - Once bootstrapped, double-clicking factor.exe or factor.com starts the Factor UI. diff --git a/basis/alien/destructors/destructors.factor b/basis/alien/destructors/destructors.factor old mode 100644 new mode 100755 index 1c5c975fe6..374d6425c4 --- a/basis/alien/destructors/destructors.factor +++ b/basis/alien/destructors/destructors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: functors destructors accessors kernel parser words -combinators.smart ; +effects generalizations sequences ; IN: alien.destructors SLOT: alien @@ -12,6 +12,7 @@ F-destructor DEFINES-CLASS ${F}-destructor DEFINES <${F}-destructor> &F DEFINES &${F} |F DEFINES |${F} +N [ F stack-effect out>> length ] WHERE @@ -19,7 +20,7 @@ TUPLE: F-destructor alien disposed ; : ( alien -- destructor ) f F-destructor boa ; inline -M: F-destructor dispose* [ alien>> F ] drop-outputs ; +M: F-destructor dispose* alien>> F N ndrop ; : &F ( alien -- alien ) dup &dispose drop ; inline diff --git a/basis/images/normalization/normalization.factor b/basis/images/normalization/normalization.factor old mode 100644 new mode 100755 index bcdf841b42..dcdf39a53e --- a/basis/images/normalization/normalization.factor +++ b/basis/images/normalization/normalization.factor @@ -61,6 +61,18 @@ M: ARGB normalize-component-order* M: ABGR normalize-component-order* drop ARGB>RGBA BGRA>RGBA ; +: fix-XBGR ( bitmap -- bitmap' ) + dup 4 [ [ 255 0 ] dip set-nth ] each ; + +M: XBGR normalize-component-order* + drop fix-XBGR ABGR normalize-component-order* ; + +: fix-BGRX ( bitmap -- bitmap' ) + dup 4 [ [ 255 3 ] dip set-nth ] each ; + +M: BGRX normalize-component-order* + drop fix-BGRX BGRA normalize-component-order* ; + : normalize-scan-line-order ( image -- image ) dup upside-down?>> [ dup dim>> first 4 * '[ diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor old mode 100644 new mode 100755 index 810aaa2c9c..67094200d1 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -17,6 +17,7 @@ M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ; M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ; M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; +M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; GENERIC: draw-texture ( texture -- ) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 12ce2bed80..e405efb540 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -433,12 +433,7 @@ M: windows-ui-backend do-events style 0 ex-style AdjustWindowRectEx win32-error=0/f ; : make-RECT ( world -- RECT ) - [ window-loc>> dup ] [ dim>> ] bi v+ - "RECT" - over first over set-RECT-right - swap second over set-RECT-bottom - over first over set-RECT-left - swap second over set-RECT-top ; + [ window-loc>> ] [ dim>> ] bi ; : default-position-RECT ( RECT -- ) dup get-RECT-dimensions [ 2drop ] 2dip diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor old mode 100644 new mode 100755 index 3704189e48..514d918e2f --- a/basis/ui/text/core-text/core-text.factor +++ b/basis/ui/text/core-text/core-text.factor @@ -10,9 +10,6 @@ IN: ui.text.core-text SINGLETON: core-text-renderer -M: core-text-renderer init-text-rendering - >>text-handle drop ; - M: core-text-renderer string-dim [ " " string-dim { 0 1 } v* ] [ cached-line dim>> ] diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor index 017a4b2cf2..3f4808a208 100755 --- a/basis/ui/text/pango/pango.factor +++ b/basis/ui/text/pango/pango.factor @@ -7,9 +7,6 @@ IN: ui.text.pango SINGLETON: pango-renderer -M: pango-renderer init-text-rendering - >>text-handle drop ; - M: pango-renderer string-dim [ " " string-dim { 0 1 } v* ] [ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ; diff --git a/basis/ui/text/text-tests.factor b/basis/ui/text/text-tests.factor old mode 100644 new mode 100755 index 939e262997..7ee901dc80 --- a/basis/ui/text/text-tests.factor +++ b/basis/ui/text/text-tests.factor @@ -1,6 +1,22 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test ui.text fonts ; +USING: tools.test ui.text fonts math accessors kernel sequences ; IN: ui.text.tests -[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test +[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test +[ t ] [ 1 sans-serif-font "aaa" offset>x 0.0 > ] unit-test +[ t ] [ 3 sans-serif-font "aaa" offset>x 0.0 > ] unit-test +[ t ] [ 1 monospace-font "a" offset>x 0.0 > ] unit-test +[ 0 ] [ 0 sans-serif-font "aaa" x>offset ] unit-test +[ 3 ] [ 100 sans-serif-font "aaa" x>offset ] unit-test +[ 0 ] [ 0 sans-serif-font "" x>offset ] unit-test + +[ t ] [ + sans-serif-font "aaa" line-metrics + [ [ ascent>> ] [ descent>> ] bi + ] [ height>> ] bi = +] unit-test + +[ f ] [ sans-serif-font "\0a" text-dim first zero? ] unit-test +[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test + +[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor old mode 100644 new mode 100755 index ebf4b9cce0..d787fe8ea9 --- a/basis/ui/text/text.factor +++ b/basis/ui/text/text.factor @@ -1,17 +1,16 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays sequences math math.order opengl opengl.gl -strings fonts colors accessors namespaces ui.gadgets.worlds ; +USING: kernel arrays sequences math math.order cache opengl +opengl.gl strings fonts colors accessors namespaces +ui.gadgets.worlds ; IN: ui.text > [ dup init-text-rendering ] unless + dup text-handle>> [ >>text-handle ] unless text-handle>> ; HOOK: flush-layout-cache font-renderer ( -- ) @@ -79,7 +78,7 @@ USING: vocabs.loader namespaces system combinators ; "ui-backend" get [ { { [ os macosx? ] [ "core-text" ] } - { [ os windows? ] [ "pango" ] } + { [ os windows? ] [ "uniscribe" ] } { [ os unix? ] [ "pango" ] } } cond ] unless* "ui.text." prepend require \ No newline at end of file diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor new file mode 100755 index 0000000000..f7d4207927 --- /dev/null +++ b/basis/ui/text/uniscribe/uniscribe.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs cache kernel math.vectors sequences +namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds +windows.uniscribe ; +IN: ui.text.uniscribe + +SINGLETON: uniscribe-renderer + +M: uniscribe-renderer string-dim + [ " " string-dim { 0 1 } v* ] + [ cached-script-string size>> ] if-empty ; + +M: uniscribe-renderer flush-layout-cache + cached-script-strings get purge-cache ; + +: rendered-script-string ( font string -- texture ) + world get world-text-handle + [ cached-script-string [ image>> ] [ text-position vneg ] bi ] + 2cache ; + +M: uniscribe-renderer draw-string ( font string -- ) + [ drop ] [ rendered-script-string draw-texture ] if-empty ; + +M: uniscribe-renderer x>offset ( x font string -- n ) + [ 2drop 0 ] [ + cached-script-string x>line-offset drop + ] if-empty ; + +M: uniscribe-renderer offset>x ( n font string -- x ) + [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ; + +M: uniscribe-renderer font-metrics ( font -- metrics ) + " " cached-script-string metrics>> clone f >>width ; + +M: uniscribe-renderer line-metrics ( font string -- metrics ) + [ " " line-metrics clone 0 >>width ] + [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ] + if-empty ; + +uniscribe-renderer font-renderer set-global diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor new file mode 100755 index 0000000000..b9fb48d840 --- /dev/null +++ b/basis/windows/fonts/fonts.factor @@ -0,0 +1,37 @@ +USING: assocs memoize locals kernel accessors init fonts +combinators windows windows.types windows.gdi32 ; +IN: windows.fonts + +: windows-font-name ( string -- string' ) + H{ + { "sans-serif" "Tahoma" } + { "serif" "Times New Roman" } + { "monospace" "Courier New" } + } at-default ; + +MEMO:: (cache-font) ( font -- HFONT ) + font size>> ! nHeight + 0 0 0 ! nWidth, nEscapement, nOrientation + font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight + font italic?>> TRUE FALSE ? ! fdwItalic + FALSE ! fdwUnderline + FALSE ! fdWStrikeOut + DEFAULT_CHARSET ! fdwCharSet + OUT_OUTLINE_PRECIS ! fdwOutputPrecision + CLIP_DEFAULT_PRECIS ! fdwClipPrecision + DEFAULT_QUALITY ! fdwQuality + DEFAULT_PITCH ! fdwPitchAndFamily + font name>> windows-font-name + CreateFont + dup win32-error=0/f ; + +: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ; + +[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook + +: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics ) + [ metrics new 0 >>width ] dip { + [ TEXTMETRICW-tmHeight >>height ] + [ TEXTMETRICW-tmAscent >>ascent ] + [ TEXTMETRICW-tmDescent >>descent ] + } cleave ; diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 2281255a4f..549286d4f0 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1,37 +1,1272 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax alien.destructors kernel windows.types ; +USING: alien alien.syntax alien.destructors kernel windows.types +math.bitwise ; IN: windows.gdi32 -! Stock Logical Objects -CONSTANT: WHITE_BRUSH 0 -CONSTANT: LTGRAY_BRUSH 1 -CONSTANT: GRAY_BRUSH 2 -CONSTANT: DKGRAY_BRUSH 3 -CONSTANT: BLACK_BRUSH 4 -CONSTANT: NULL_BRUSH 5 -ALIAS: HOLLOW_BRUSH NULL_BRUSH -CONSTANT: WHITE_PEN 6 -CONSTANT: BLACK_PEN 7 -CONSTANT: NULL_PEN 8 -CONSTANT: OEM_FIXED_FONT 10 -CONSTANT: ANSI_FIXED_FONT 11 -CONSTANT: ANSI_VAR_FONT 12 -CONSTANT: SYSTEM_FONT 13 -CONSTANT: DEVICE_DEFAULT_FONT 14 -CONSTANT: DEFAULT_PALETTE 15 -CONSTANT: SYSTEM_FIXED_FONT 16 -CONSTANT: DEFAULT_GUI_FONT 17 -CONSTANT: DC_BRUSH 18 -CONSTANT: DC_PEN 19 - -CONSTANT: BI_RGB 0 -CONSTANT: BI_RLE8 1 -CONSTANT: BI_RLE4 2 -CONSTANT: BI_BITFIELDS 3 - -CONSTANT: DIB_RGB_COLORS 0 +CONSTANT: BI_RGB 0 +CONSTANT: BI_RLE8 1 +CONSTANT: BI_RLE4 2 +CONSTANT: BI_BITFIELDS 3 +CONSTANT: BI_JPEG 4 +CONSTANT: BI_PNG 5 +CONSTANT: LF_FACESIZE 32 +CONSTANT: LF_FULLFACESIZE 64 +CONSTANT: CA_NEGATIVE 1 +CONSTANT: CA_LOG_FILTER 2 +CONSTANT: ILLUMINANT_DEVICE_DEFAULT 0 +CONSTANT: ILLUMINANT_A 1 +CONSTANT: ILLUMINANT_B 2 +CONSTANT: ILLUMINANT_C 3 +CONSTANT: ILLUMINANT_D50 4 +CONSTANT: ILLUMINANT_D55 5 +CONSTANT: ILLUMINANT_D65 6 +CONSTANT: ILLUMINANT_D75 7 +CONSTANT: ILLUMINANT_F2 8 +ALIAS: ILLUMINANT_MAX_INDEX ILLUMINANT_F2 +ALIAS: ILLUMINANT_TUNGSTEN ILLUMINANT_A +ALIAS: ILLUMINANT_DAYLIGHT ILLUMINANT_C +ALIAS: ILLUMINANT_FLUORESCENT ILLUMINANT_F2 +ALIAS: ILLUMINANT_NTSC ILLUMINANT_C +CONSTANT: RGB_GAMMA_MIN 2500 +CONSTANT: RGB_GAMMA_MAX 65000 +CONSTANT: REFERENCE_WHITE_MIN 6000 +CONSTANT: REFERENCE_WHITE_MAX 10000 +CONSTANT: REFERENCE_BLACK_MIN 0 +CONSTANT: REFERENCE_BLACK_MAX 4000 +CONSTANT: COLOR_ADJ_MIN -100 +CONSTANT: COLOR_ADJ_MAX 100 +CONSTANT: CCHDEVICENAME 32 +CONSTANT: CCHFORMNAME 32 +CONSTANT: DI_COMPAT 4 +CONSTANT: DI_DEFAULTSIZE 8 +CONSTANT: DI_IMAGE 2 +CONSTANT: DI_MASK 1 +CONSTANT: DI_NORMAL 3 +CONSTANT: DI_APPBANDING 1 +CONSTANT: EMR_HEADER 1 +CONSTANT: EMR_POLYBEZIER 2 +CONSTANT: EMR_POLYGON 3 +CONSTANT: EMR_POLYLINE 4 +CONSTANT: EMR_POLYBEZIERTO 5 +CONSTANT: EMR_POLYLINETO 6 +CONSTANT: EMR_POLYPOLYLINE 7 +CONSTANT: EMR_POLYPOLYGON 8 +CONSTANT: EMR_SETWINDOWEXTEX 9 +CONSTANT: EMR_SETWINDOWORGEX 10 +CONSTANT: EMR_SETVIEWPORTEXTEX 11 +CONSTANT: EMR_SETVIEWPORTORGEX 12 +CONSTANT: EMR_SETBRUSHORGEX 13 +CONSTANT: EMR_EOF 14 +CONSTANT: EMR_SETPIXELV 15 +CONSTANT: EMR_SETMAPPERFLAGS 16 +CONSTANT: EMR_SETMAPMODE 17 +CONSTANT: EMR_SETBKMODE 18 +CONSTANT: EMR_SETPOLYFILLMODE 19 +CONSTANT: EMR_SETROP2 20 +CONSTANT: EMR_SETSTRETCHBLTMODE 21 +CONSTANT: EMR_SETTEXTALIGN 22 +CONSTANT: EMR_SETCOLORADJUSTMENT 23 +CONSTANT: EMR_SETTEXTCOLOR 24 +CONSTANT: EMR_SETBKCOLOR 25 +CONSTANT: EMR_OFFSETCLIPRGN 26 +CONSTANT: EMR_MOVETOEX 27 +CONSTANT: EMR_SETMETARGN 28 +CONSTANT: EMR_EXCLUDECLIPRECT 29 +CONSTANT: EMR_INTERSECTCLIPRECT 30 +CONSTANT: EMR_SCALEVIEWPORTEXTEX 31 +CONSTANT: EMR_SCALEWINDOWEXTEX 32 +CONSTANT: EMR_SAVEDC 33 +CONSTANT: EMR_RESTOREDC 34 +CONSTANT: EMR_SETWORLDTRANSFORM 35 +CONSTANT: EMR_MODIFYWORLDTRANSFORM 36 +CONSTANT: EMR_SELECTOBJECT 37 +CONSTANT: EMR_CREATEPEN 38 +CONSTANT: EMR_CREATEBRUSHINDIRECT 39 +CONSTANT: EMR_DELETEOBJECT 40 +CONSTANT: EMR_ANGLEARC 41 +CONSTANT: EMR_ELLIPSE 42 +CONSTANT: EMR_RECTANGLE 43 +CONSTANT: EMR_ROUNDRECT 44 +CONSTANT: EMR_ARC 45 +CONSTANT: EMR_CHORD 46 +CONSTANT: EMR_PIE 47 +CONSTANT: EMR_SELECTPALETTE 48 +CONSTANT: EMR_CREATEPALETTE 49 +CONSTANT: EMR_SETPALETTEENTRIES 50 +CONSTANT: EMR_RESIZEPALETTE 51 +CONSTANT: EMR_REALIZEPALETTE 52 +CONSTANT: EMR_EXTFLOODFILL 53 +CONSTANT: EMR_LINETO 54 +CONSTANT: EMR_ARCTO 55 +CONSTANT: EMR_POLYDRAW 56 +CONSTANT: EMR_SETARCDIRECTION 57 +CONSTANT: EMR_SETMITERLIMIT 58 +CONSTANT: EMR_BEGINPATH 59 +CONSTANT: EMR_ENDPATH 60 +CONSTANT: EMR_CLOSEFIGURE 61 +CONSTANT: EMR_FILLPATH 62 +CONSTANT: EMR_STROKEANDFILLPATH 63 +CONSTANT: EMR_STROKEPATH 64 +CONSTANT: EMR_FLATTENPATH 65 +CONSTANT: EMR_WIDENPATH 66 +CONSTANT: EMR_SELECTCLIPPATH 67 +CONSTANT: EMR_ABORTPATH 68 +CONSTANT: EMR_GDICOMMENT 70 +CONSTANT: EMR_FILLRGN 71 +CONSTANT: EMR_FRAMERGN 72 +CONSTANT: EMR_INVERTRGN 73 +CONSTANT: EMR_PAINTRGN 74 +CONSTANT: EMR_EXTSELECTCLIPRGN 75 +CONSTANT: EMR_BITBLT 76 +CONSTANT: EMR_STRETCHBLT 77 +CONSTANT: EMR_MASKBLT 78 +CONSTANT: EMR_PLGBLT 79 +CONSTANT: EMR_SETDIBITSTODEVICE 80 +CONSTANT: EMR_STRETCHDIBITS 81 +CONSTANT: EMR_EXTCREATEFONTINDIRECTW 82 +CONSTANT: EMR_EXTTEXTOUTA 83 +CONSTANT: EMR_EXTTEXTOUTW 84 +CONSTANT: EMR_POLYBEZIER16 85 +CONSTANT: EMR_POLYGON16 86 +CONSTANT: EMR_POLYLINE16 87 +CONSTANT: EMR_POLYBEZIERTO16 88 +CONSTANT: EMR_POLYLINETO16 89 +CONSTANT: EMR_POLYPOLYLINE16 90 +CONSTANT: EMR_POLYPOLYGON16 91 +CONSTANT: EMR_POLYDRAW16 92 +CONSTANT: EMR_CREATEMONOBRUSH 93 +CONSTANT: EMR_CREATEDIBPATTERNBRUSHPT 94 +CONSTANT: EMR_EXTCREATEPEN 95 +CONSTANT: EMR_POLYTEXTOUTA 96 +CONSTANT: EMR_POLYTEXTOUTW 97 +CONSTANT: EMR_SETICMMODE 98 +CONSTANT: EMR_CREATECOLORSPACE 99 +CONSTANT: EMR_SETCOLORSPACE 100 +CONSTANT: EMR_DELETECOLORSPACE 101 +CONSTANT: EMR_GLSRECORD 102 +CONSTANT: EMR_GLSBOUNDEDRECORD 103 +CONSTANT: EMR_PIXELFORMAT 104 +CONSTANT: ENHMETA_SIGNATURE 1179469088 +CONSTANT: EPS_SIGNATURE HEX: 46535045 +CONSTANT: FR_PRIVATE HEX: 10 +CONSTANT: FR_NOT_ENUM HEX: 20 +CONSTANT: META_SETBKCOLOR HEX: 201 +CONSTANT: META_SETBKMODE HEX: 102 +CONSTANT: META_SETMAPMODE HEX: 103 +CONSTANT: META_SETROP2 HEX: 104 +CONSTANT: META_SETRELABS HEX: 105 +CONSTANT: META_SETPOLYFILLMODE HEX: 106 +CONSTANT: META_SETSTRETCHBLTMODE HEX: 107 +CONSTANT: META_SETTEXTCHAREXTRA HEX: 108 +CONSTANT: META_SETTEXTCOLOR HEX: 209 +CONSTANT: META_SETTEXTJUSTIFICATION HEX: 20A +CONSTANT: META_SETWINDOWORG HEX: 20B +CONSTANT: META_SETWINDOWEXT HEX: 20C +CONSTANT: META_SETVIEWPORTORG HEX: 20D +CONSTANT: META_SETVIEWPORTEXT HEX: 20E +CONSTANT: META_OFFSETWINDOWORG HEX: 20F +CONSTANT: META_SCALEWINDOWEXT HEX: 410 +CONSTANT: META_OFFSETVIEWPORTORG HEX: 211 +CONSTANT: META_SCALEVIEWPORTEXT HEX: 412 +CONSTANT: META_LINETO HEX: 213 +CONSTANT: META_MOVETO HEX: 214 +CONSTANT: META_EXCLUDECLIPRECT HEX: 415 +CONSTANT: META_INTERSECTCLIPRECT HEX: 416 +CONSTANT: META_ARC HEX: 817 +CONSTANT: META_ELLIPSE HEX: 418 +CONSTANT: META_FLOODFILL HEX: 419 +CONSTANT: META_PIE HEX: 81A +CONSTANT: META_RECTANGLE HEX: 41B +CONSTANT: META_ROUNDRECT HEX: 61C +CONSTANT: META_PATBLT HEX: 61D +CONSTANT: META_SAVEDC HEX: 1E +CONSTANT: META_SETPIXEL HEX: 41F +CONSTANT: META_OFFSETCLIPRGN HEX: 220 +CONSTANT: META_TEXTOUT HEX: 521 +CONSTANT: META_BITBLT HEX: 922 +CONSTANT: META_STRETCHBLT HEX: b23 +CONSTANT: META_POLYGON HEX: 324 +CONSTANT: META_POLYLINE HEX: 325 +CONSTANT: META_ESCAPE HEX: 626 +CONSTANT: META_RESTOREDC HEX: 127 +CONSTANT: META_FILLREGION HEX: 228 +CONSTANT: META_FRAMEREGION HEX: 429 +CONSTANT: META_INVERTREGION HEX: 12A +CONSTANT: META_PAINTREGION HEX: 12B +CONSTANT: META_SELECTCLIPREGION HEX: 12C +CONSTANT: META_SELECTOBJECT HEX: 12D +CONSTANT: META_SETTEXTALIGN HEX: 12E +CONSTANT: META_CHORD HEX: 830 +CONSTANT: META_SETMAPPERFLAGS HEX: 231 +CONSTANT: META_EXTTEXTOUT HEX: a32 +CONSTANT: META_SETDIBTODEV HEX: d33 +CONSTANT: META_SELECTPALETTE HEX: 234 +CONSTANT: META_REALIZEPALETTE HEX: 35 +CONSTANT: META_ANIMATEPALETTE HEX: 436 +CONSTANT: META_SETPALENTRIES HEX: 37 +CONSTANT: META_POLYPOLYGON HEX: 538 +CONSTANT: META_RESIZEPALETTE HEX: 139 +CONSTANT: META_DIBBITBLT HEX: 940 +CONSTANT: META_DIBSTRETCHBLT HEX: b41 +CONSTANT: META_DIBCREATEPATTERNBRUSH HEX: 142 +CONSTANT: META_STRETCHDIB HEX: f43 +CONSTANT: META_EXTFLOODFILL HEX: 548 +CONSTANT: META_DELETEOBJECT HEX: 1f0 +CONSTANT: META_CREATEPALETTE HEX: f7 +CONSTANT: META_CREATEPATTERNBRUSH HEX: 1F9 +CONSTANT: META_CREATEPENINDIRECT HEX: 2FA +CONSTANT: META_CREATEFONTINDIRECT HEX: 2FB +CONSTANT: META_CREATEBRUSHINDIRECT HEX: 2FC +CONSTANT: META_CREATEREGION HEX: 6FF +CONSTANT: ELF_VENDOR_SIZE 4 +CONSTANT: ELF_VERSION 0 +CONSTANT: ELF_CULTURE_LATIN 0 +CONSTANT: PFD_TYPE_RGBA 0 +CONSTANT: PFD_TYPE_COLORINDEX 1 +CONSTANT: PFD_MAIN_PLANE 0 +CONSTANT: PFD_OVERLAY_PLANE 1 +CONSTANT: PFD_UNDERLAY_PLANE -1 +CONSTANT: PFD_DOUBLEBUFFER 1 +CONSTANT: PFD_STEREO 2 +CONSTANT: PFD_DRAW_TO_WINDOW 4 +CONSTANT: PFD_DRAW_TO_BITMAP 8 +CONSTANT: PFD_SUPPORT_GDI 16 +CONSTANT: PFD_SUPPORT_OPENGL 32 +CONSTANT: PFD_GENERIC_FORMAT 64 +CONSTANT: PFD_NEED_PALETTE 128 +CONSTANT: PFD_NEED_SYSTEM_PALETTE HEX: 00000100 +CONSTANT: PFD_SWAP_EXCHANGE HEX: 00000200 +CONSTANT: PFD_SWAP_COPY HEX: 00000400 +CONSTANT: PFD_SWAP_LAYER_BUFFERS HEX: 00000800 +CONSTANT: PFD_GENERIC_ACCELERATED HEX: 00001000 +CONSTANT: PFD_DEPTH_DONTCARE HEX: 20000000 +CONSTANT: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000 +CONSTANT: PFD_STEREO_DONTCARE HEX: 80000000 +CONSTANT: SP_ERROR -1 +CONSTANT: SP_OUTOFDISK -4 +CONSTANT: SP_OUTOFMEMORY -5 +CONSTANT: SP_USERABORT -3 +CONSTANT: SP_APPABORT -2 +CONSTANT: BLACKNESS HEX: 00000042 +CONSTANT: NOTSRCERASE HEX: 001100A6 +CONSTANT: NOTSRCCOPY HEX: 00330008 +CONSTANT: SRCERASE HEX: 00440328 +CONSTANT: DSTINVERT HEX: 00550009 +CONSTANT: PATINVERT HEX: 005A0049 +CONSTANT: SRCINVERT HEX: 00660046 +CONSTANT: SRCAND HEX: 008800C6 +CONSTANT: MERGEPAINT HEX: 00BB0226 +CONSTANT: MERGECOPY HEX: 00C000CA +CONSTANT: SRCCOPY HEX: 00CC0020 +CONSTANT: SRCPAINT HEX: 00EE0086 +CONSTANT: PATCOPY HEX: 00F00021 +CONSTANT: PATPAINT HEX: 00FB0A09 +CONSTANT: WHITENESS HEX: 00FF0062 +CONSTANT: CAPTUREBLT HEX: 40000000 +CONSTANT: NOMIRRORBITMAP HEX: 80000000 +CONSTANT: R2_BLACK 1 +CONSTANT: R2_COPYPEN 13 +CONSTANT: R2_MASKNOTPEN 3 +CONSTANT: R2_MASKPEN 9 +CONSTANT: R2_MASKPENNOT 5 +CONSTANT: R2_MERGENOTPEN 12 +CONSTANT: R2_MERGEPEN 15 +CONSTANT: R2_MERGEPENNOT 14 +CONSTANT: R2_NOP 11 +CONSTANT: R2_NOT 6 +CONSTANT: R2_NOTCOPYPEN 4 +CONSTANT: R2_NOTMASKPEN 8 +CONSTANT: R2_NOTMERGEPEN 2 +CONSTANT: R2_NOTXORPEN 10 +CONSTANT: R2_WHITE 16 +CONSTANT: R2_XORPEN 7 +CONSTANT: CM_OUT_OF_GAMUT 255 +CONSTANT: CM_IN_GAMUT 0 +CONSTANT: RGN_AND 1 +CONSTANT: RGN_COPY 5 +CONSTANT: RGN_DIFF 4 +CONSTANT: RGN_OR 2 +CONSTANT: RGN_XOR 3 +CONSTANT: NULLREGION 1 +CONSTANT: SIMPLEREGION 2 +CONSTANT: COMPLEXREGION 3 +CONSTANT: ERROR 0 +CONSTANT: CBM_INIT 4 CONSTANT: DIB_PAL_COLORS 1 +CONSTANT: DIB_RGB_COLORS 0 +CONSTANT: FW_DONTCARE 0 +CONSTANT: FW_THIN 100 +CONSTANT: FW_EXTRALIGHT 200 +ALIAS: FW_ULTRALIGHT FW_EXTRALIGHT +CONSTANT: FW_LIGHT 300 +CONSTANT: FW_NORMAL 400 +CONSTANT: FW_REGULAR 400 +CONSTANT: FW_MEDIUM 500 +CONSTANT: FW_SEMIBOLD 600 +ALIAS: FW_DEMIBOLD FW_SEMIBOLD +CONSTANT: FW_BOLD 700 +CONSTANT: FW_EXTRABOLD 800 +ALIAS: FW_ULTRABOLD FW_EXTRABOLD +CONSTANT: FW_HEAVY 900 +ALIAS: FW_BLACK FW_HEAVY +CONSTANT: ANSI_CHARSET 0 +CONSTANT: DEFAULT_CHARSET 1 +CONSTANT: SYMBOL_CHARSET 2 +CONSTANT: SHIFTJIS_CHARSET 128 +CONSTANT: HANGEUL_CHARSET 129 +CONSTANT: HANGUL_CHARSET 129 +CONSTANT: GB2312_CHARSET 134 +CONSTANT: CHINESEBIG5_CHARSET 136 +CONSTANT: GREEK_CHARSET 161 +CONSTANT: TURKISH_CHARSET 162 +CONSTANT: HEBREW_CHARSET 177 +CONSTANT: ARABIC_CHARSET 178 +CONSTANT: BALTIC_CHARSET 186 +CONSTANT: RUSSIAN_CHARSET 204 +CONSTANT: THAI_CHARSET 222 +CONSTANT: EASTEUROPE_CHARSET 238 +CONSTANT: OEM_CHARSET 255 +CONSTANT: JOHAB_CHARSET 130 +CONSTANT: VIETNAMESE_CHARSET 163 +CONSTANT: MAC_CHARSET 77 +CONSTANT: OUT_DEFAULT_PRECIS 0 +CONSTANT: OUT_STRING_PRECIS 1 +CONSTANT: OUT_CHARACTER_PRECIS 2 +CONSTANT: OUT_STROKE_PRECIS 3 +CONSTANT: OUT_TT_PRECIS 4 +CONSTANT: OUT_DEVICE_PRECIS 5 +CONSTANT: OUT_RASTER_PRECIS 6 +CONSTANT: OUT_TT_ONLY_PRECIS 7 +CONSTANT: OUT_OUTLINE_PRECIS 8 +CONSTANT: CLIP_DEFAULT_PRECIS 0 +CONSTANT: CLIP_CHARACTER_PRECIS 1 +CONSTANT: CLIP_STROKE_PRECIS 2 +CONSTANT: CLIP_MASK 15 +CONSTANT: CLIP_LH_ANGLES 16 +CONSTANT: CLIP_TT_ALWAYS 32 +CONSTANT: CLIP_EMBEDDED 128 +CONSTANT: DEFAULT_QUALITY 0 +CONSTANT: DRAFT_QUALITY 1 +CONSTANT: PROOF_QUALITY 2 +CONSTANT: NONANTIALIASED_QUALITY 3 +CONSTANT: ANTIALIASED_QUALITY 4 +CONSTANT: DEFAULT_PITCH 0 +CONSTANT: FIXED_PITCH 1 +CONSTANT: VARIABLE_PITCH 2 +CONSTANT: MONO_FONT 8 +CONSTANT: FF_DECORATIVE 80 +CONSTANT: FF_DONTCARE 0 +CONSTANT: FF_MODERN 48 +CONSTANT: FF_ROMAN 16 +CONSTANT: FF_SCRIPT 64 +CONSTANT: FF_SWISS 32 +CONSTANT: PANOSE_COUNT 10 +CONSTANT: PAN_FAMILYTYPE_INDEX 0 +CONSTANT: PAN_SERIFSTYLE_INDEX 1 +CONSTANT: PAN_WEIGHT_INDEX 2 +CONSTANT: PAN_PROPORTION_INDEX 3 +CONSTANT: PAN_CONTRAST_INDEX 4 +CONSTANT: PAN_STROKEVARIATION_INDEX 5 +CONSTANT: PAN_ARMSTYLE_INDEX 6 +CONSTANT: PAN_LETTERFORM_INDEX 7 +CONSTANT: PAN_MIDLINE_INDEX 8 +CONSTANT: PAN_XHEIGHT_INDEX 9 +CONSTANT: PAN_CULTURE_LATIN 0 +CONSTANT: PAN_ANY 0 +CONSTANT: PAN_NO_FIT 1 +CONSTANT: PAN_FAMILY_TEXT_DISPLAY 2 +CONSTANT: PAN_FAMILY_SCRIPT 3 +CONSTANT: PAN_FAMILY_DECORATIVE 4 +CONSTANT: PAN_FAMILY_PICTORIAL 5 +CONSTANT: PAN_SERIF_COVE 2 +CONSTANT: PAN_SERIF_OBTUSE_COVE 3 +CONSTANT: PAN_SERIF_SQUARE_COVE 4 +CONSTANT: PAN_SERIF_OBTUSE_SQUARE_COVE 5 +CONSTANT: PAN_SERIF_SQUARE 6 +CONSTANT: PAN_SERIF_THIN 7 +CONSTANT: PAN_SERIF_BONE 8 +CONSTANT: PAN_SERIF_EXAGGERATED 9 +CONSTANT: PAN_SERIF_TRIANGLE 10 +CONSTANT: PAN_SERIF_NORMAL_SANS 11 +CONSTANT: PAN_SERIF_OBTUSE_SANS 12 +CONSTANT: PAN_SERIF_PERP_SANS 13 +CONSTANT: PAN_SERIF_FLARED 14 +CONSTANT: PAN_SERIF_ROUNDED 15 +CONSTANT: PAN_WEIGHT_VERY_LIGHT 2 +CONSTANT: PAN_WEIGHT_LIGHT 3 +CONSTANT: PAN_WEIGHT_THIN 4 +CONSTANT: PAN_WEIGHT_BOOK 5 +CONSTANT: PAN_WEIGHT_MEDIUM 6 +CONSTANT: PAN_WEIGHT_DEMI 7 +CONSTANT: PAN_WEIGHT_BOLD 8 +CONSTANT: PAN_WEIGHT_HEAVY 9 +CONSTANT: PAN_WEIGHT_BLACK 10 +CONSTANT: PAN_WEIGHT_NORD 11 +CONSTANT: PAN_PROP_OLD_STYLE 2 +CONSTANT: PAN_PROP_MODERN 3 +CONSTANT: PAN_PROP_EVEN_WIDTH 4 +CONSTANT: PAN_PROP_EXPANDED 5 +CONSTANT: PAN_PROP_CONDENSED 6 +CONSTANT: PAN_PROP_VERY_EXPANDED 7 +CONSTANT: PAN_PROP_VERY_CONDENSED 8 +CONSTANT: PAN_PROP_MONOSPACED 9 +CONSTANT: PAN_CONTRAST_NONE 2 +CONSTANT: PAN_CONTRAST_VERY_LOW 3 +CONSTANT: PAN_CONTRAST_LOW 4 +CONSTANT: PAN_CONTRAST_MEDIUM_LOW 5 +CONSTANT: PAN_CONTRAST_MEDIUM 6 +CONSTANT: PAN_CONTRAST_MEDIUM_HIGH 7 +CONSTANT: PAN_CONTRAST_HIGH 8 +CONSTANT: PAN_CONTRAST_VERY_HIGH 9 +CONSTANT: PAN_STROKE_GRADUAL_DIAG 2 +CONSTANT: PAN_STROKE_GRADUAL_TRAN 3 +CONSTANT: PAN_STROKE_GRADUAL_VERT 4 +CONSTANT: PAN_STROKE_GRADUAL_HORZ 5 +CONSTANT: PAN_STROKE_RAPID_VERT 6 +CONSTANT: PAN_STROKE_RAPID_HORZ 7 +CONSTANT: PAN_STROKE_INSTANT_VERT 8 +CONSTANT: PAN_STRAIGHT_ARMS_HORZ 2 +CONSTANT: PAN_STRAIGHT_ARMS_WEDGE 3 +CONSTANT: PAN_STRAIGHT_ARMS_VERT 4 +CONSTANT: PAN_STRAIGHT_ARMS_SINGLE_SERIF 5 +CONSTANT: PAN_STRAIGHT_ARMS_DOUBLE_SERIF 6 +CONSTANT: PAN_BENT_ARMS_HORZ 7 +CONSTANT: PAN_BENT_ARMS_WEDGE 8 +CONSTANT: PAN_BENT_ARMS_VERT 9 +CONSTANT: PAN_BENT_ARMS_SINGLE_SERIF 10 +CONSTANT: PAN_BENT_ARMS_DOUBLE_SERIF 11 +CONSTANT: PAN_LETT_NORMAL_CONTACT 2 +CONSTANT: PAN_LETT_NORMAL_WEIGHTED 3 +CONSTANT: PAN_LETT_NORMAL_BOXED 4 +CONSTANT: PAN_LETT_NORMAL_FLATTENED 5 +CONSTANT: PAN_LETT_NORMAL_ROUNDED 6 +CONSTANT: PAN_LETT_NORMAL_OFF_CENTER 7 +CONSTANT: PAN_LETT_NORMAL_SQUARE 8 +CONSTANT: PAN_LETT_OBLIQUE_CONTACT 9 +CONSTANT: PAN_LETT_OBLIQUE_WEIGHTED 10 +CONSTANT: PAN_LETT_OBLIQUE_BOXED 11 +CONSTANT: PAN_LETT_OBLIQUE_FLATTENED 12 +CONSTANT: PAN_LETT_OBLIQUE_ROUNDED 13 +CONSTANT: PAN_LETT_OBLIQUE_OFF_CENTER 14 +CONSTANT: PAN_LETT_OBLIQUE_SQUARE 15 +CONSTANT: PAN_MIDLINE_STANDARD_TRIMMED 2 +CONSTANT: PAN_MIDLINE_STANDARD_POINTED 3 +CONSTANT: PAN_MIDLINE_STANDARD_SERIFED 4 +CONSTANT: PAN_MIDLINE_HIGH_TRIMMED 5 +CONSTANT: PAN_MIDLINE_HIGH_POINTED 6 +CONSTANT: PAN_MIDLINE_HIGH_SERIFED 7 +CONSTANT: PAN_MIDLINE_CONSTANT_TRIMMED 8 +CONSTANT: PAN_MIDLINE_CONSTANT_POINTED 9 +CONSTANT: PAN_MIDLINE_CONSTANT_SERIFED 10 +CONSTANT: PAN_MIDLINE_LOW_TRIMMED 11 +CONSTANT: PAN_MIDLINE_LOW_POINTED 12 +CONSTANT: PAN_MIDLINE_LOW_SERIFED 13 +CONSTANT: PAN_XHEIGHT_CONSTANT_SMALL 2 +CONSTANT: PAN_XHEIGHT_CONSTANT_STD 3 +CONSTANT: PAN_XHEIGHT_CONSTANT_LARGE 4 +CONSTANT: PAN_XHEIGHT_DUCKING_SMALL 5 +CONSTANT: PAN_XHEIGHT_DUCKING_STD 6 +CONSTANT: PAN_XHEIGHT_DUCKING_LARGE 7 +CONSTANT: FS_LATIN1 1 +CONSTANT: FS_LATIN2 2 +CONSTANT: FS_CYRILLIC 4 +CONSTANT: FS_GREEK 8 +CONSTANT: FS_TURKISH 16 +CONSTANT: FS_HEBREW 32 +CONSTANT: FS_ARABIC 64 +CONSTANT: FS_BALTIC 128 +CONSTANT: FS_THAI HEX: 10000 +CONSTANT: FS_JISJAPAN HEX: 20000 +CONSTANT: FS_CHINESESIMP HEX: 40000 +CONSTANT: FS_WANSUNG HEX: 80000 +CONSTANT: FS_CHINESETRAD HEX: 100000 +CONSTANT: FS_JOHAB HEX: 200000 +CONSTANT: FS_SYMBOL HEX: 80000000 +CONSTANT: HS_BDIAGONAL 3 +CONSTANT: HS_CROSS 4 +CONSTANT: HS_DIAGCROSS 5 +CONSTANT: HS_FDIAGONAL 2 +CONSTANT: HS_HORIZONTAL 0 +CONSTANT: HS_VERTICAL 1 +CONSTANT: PS_GEOMETRIC 65536 +CONSTANT: PS_COSMETIC 0 +CONSTANT: PS_ALTERNATE 8 +CONSTANT: PS_SOLID 0 +CONSTANT: PS_DASH 1 +CONSTANT: PS_DOT 2 +CONSTANT: PS_DASHDOT 3 +CONSTANT: PS_DASHDOTDOT 4 +CONSTANT: PS_NULL 5 +CONSTANT: PS_USERSTYLE 7 +CONSTANT: PS_INSIDEFRAME 6 +CONSTANT: PS_ENDCAP_ROUND 0 +CONSTANT: PS_ENDCAP_SQUARE 256 +CONSTANT: PS_ENDCAP_FLAT 512 +CONSTANT: PS_JOIN_BEVEL 4096 +CONSTANT: PS_JOIN_MITER 8192 +CONSTANT: PS_JOIN_ROUND 0 +CONSTANT: PS_STYLE_MASK 15 +CONSTANT: PS_ENDCAP_MASK 3840 +CONSTANT: PS_TYPE_MASK 983040 +CONSTANT: ALTERNATE 1 +CONSTANT: WINDING 2 +CONSTANT: DC_BINNAMES 12 +CONSTANT: DC_BINS 6 +CONSTANT: DC_COPIES 18 +CONSTANT: DC_DRIVER 11 +CONSTANT: DC_DATATYPE_PRODUCED 21 +CONSTANT: DC_DUPLEX 7 +CONSTANT: DC_EMF_COMPLIANT 20 +CONSTANT: DC_ENUMRESOLUTIONS 13 +CONSTANT: DC_EXTRA 9 +CONSTANT: DC_FIELDS 1 +CONSTANT: DC_FILEDEPENDENCIES 14 +CONSTANT: DC_MAXEXTENT 5 +CONSTANT: DC_MINEXTENT 4 +CONSTANT: DC_ORIENTATION 17 +CONSTANT: DC_PAPERNAMES 16 +CONSTANT: DC_PAPERS 2 +CONSTANT: DC_PAPERSIZE 3 +CONSTANT: DC_SIZE 8 +CONSTANT: DC_TRUETYPE 15 +CONSTANT: DCTT_BITMAP 1 +CONSTANT: DCTT_DOWNLOAD 2 +CONSTANT: DCTT_SUBDEV 4 +CONSTANT: DCTT_DOWNLOAD_OUTLINE 8 +CONSTANT: DC_VERSION 10 +CONSTANT: DC_BINADJUST 19 +CONSTANT: DC_MANUFACTURER 23 +CONSTANT: DC_MODEL 24 +CONSTANT: DC_PERSONALITY 25 +CONSTANT: DC_PRINTRATE 26 +CONSTANT: DC_PRINTRATEUNIT 27 +CONSTANT: DC_PRINTERMEM 28 +CONSTANT: DC_MEDIAREADY 29 +CONSTANT: DC_STAPLE 30 +CONSTANT: DC_PRINTRATEPPM 31 +CONSTANT: DC_COLORDEVICE 32 +CONSTANT: DC_NUP 33 +CONSTANT: DC_MEDIATYPENAMES 34 +CONSTANT: DC_MEDIATYPES 35 +CONSTANT: DCBA_FACEUPNONE 0 +CONSTANT: DCBA_FACEUPCENTER 1 +CONSTANT: DCBA_FACEUPLEFT 2 +CONSTANT: DCBA_FACEUPRIGHT 3 +CONSTANT: DCBA_FACEDOWNNONE 256 +CONSTANT: DCBA_FACEDOWNCENTER 257 +CONSTANT: DCBA_FACEDOWNLEFT 258 +CONSTANT: DCBA_FACEDOWNRIGHT 259 +CONSTANT: FLOODFILLBORDER 0 +CONSTANT: FLOODFILLSURFACE 1 +CONSTANT: ETO_CLIPPED HEX: 0004 +CONSTANT: ETO_GLYPH_INDEX HEX: 0010 +CONSTANT: ETO_OPAQUE HEX: 0002 +CONSTANT: ETO_NUMERICSLATIN HEX: 0800 +CONSTANT: ETO_NUMERICSLOCAL HEX: 0400 +CONSTANT: ETO_RTLREADING HEX: 0080 +CONSTANT: ETO_IGNORELANGUAGE HEX: 1000 +CONSTANT: ETO_PDY HEX: 2000 +CONSTANT: GDICOMMENT_WINDOWS_METAFILE -2147483647 +CONSTANT: GDICOMMENT_BEGINGROUP 2 +CONSTANT: GDICOMMENT_ENDGROUP 3 +CONSTANT: GDICOMMENT_MULTIFORMATS 1073741828 +CONSTANT: GDICOMMENT_IDENTIFIER 1128875079 +CONSTANT: AD_COUNTERCLOCKWISE 1 +CONSTANT: AD_CLOCKWISE 2 +CONSTANT: RDH_RECTANGLES 1 +CONSTANT: GCPCLASS_LATIN 1 +CONSTANT: GCPCLASS_HEBREW 2 +CONSTANT: GCPCLASS_ARABIC 2 +CONSTANT: GCPCLASS_NEUTRAL 3 +CONSTANT: GCPCLASS_LOCALNUMBER 4 +CONSTANT: GCPCLASS_LATINNUMBER 5 +CONSTANT: GCPCLASS_LATINNUMERICTERMINATOR 6 +CONSTANT: GCPCLASS_LATINNUMERICSEPARATOR 7 +CONSTANT: GCPCLASS_NUMERICSEPARATOR 8 +CONSTANT: GCPCLASS_PREBOUNDLTR 128 +CONSTANT: GCPCLASS_PREBOUNDRTL 64 +CONSTANT: GCPCLASS_POSTBOUNDLTR 32 +CONSTANT: GCPCLASS_POSTBOUNDRTL 16 +CONSTANT: GCPGLYPH_LINKBEFORE HEX: 8000 +CONSTANT: GCPGLYPH_LINKAFTER HEX: 4000 +CONSTANT: DCB_DISABLE 8 +CONSTANT: DCB_ENABLE 4 +CONSTANT: DCB_RESET 1 +CONSTANT: DCB_SET 3 +CONSTANT: DCB_ACCUMULATE 2 +CONSTANT: DCB_DIRTY 2 +CONSTANT: OBJ_BRUSH 2 +CONSTANT: OBJ_PEN 1 +CONSTANT: OBJ_PAL 5 +CONSTANT: OBJ_FONT 6 +CONSTANT: OBJ_BITMAP 7 +CONSTANT: OBJ_EXTPEN 11 +CONSTANT: OBJ_REGION 8 +CONSTANT: OBJ_DC 3 +CONSTANT: OBJ_MEMDC 10 +CONSTANT: OBJ_METAFILE 9 +CONSTANT: OBJ_METADC 4 +CONSTANT: OBJ_ENHMETAFILE 13 +CONSTANT: OBJ_ENHMETADC 12 +CONSTANT: DRIVERVERSION 0 +CONSTANT: TECHNOLOGY 2 +CONSTANT: DT_PLOTTER 0 +CONSTANT: DT_RASDISPLAY 1 +CONSTANT: DT_RASPRINTER 2 +CONSTANT: DT_RASCAMERA 3 +CONSTANT: DT_CHARSTREAM 4 +CONSTANT: DT_METAFILE 5 +CONSTANT: DT_DISPFILE 6 +CONSTANT: HORZSIZE 4 +CONSTANT: VERTSIZE 6 +CONSTANT: HORZRES 8 +CONSTANT: VERTRES 10 +CONSTANT: LOGPIXELSX 88 +CONSTANT: LOGPIXELSY 90 +CONSTANT: BITSPIXEL 12 +CONSTANT: PLANES 14 +CONSTANT: NUMBRUSHES 16 +CONSTANT: NUMPENS 18 +CONSTANT: NUMFONTS 22 +CONSTANT: NUMCOLORS 24 +CONSTANT: NUMMARKERS 20 +CONSTANT: ASPECTX 40 +CONSTANT: ASPECTY 42 +CONSTANT: ASPECTXY 44 +CONSTANT: PDEVICESIZE 26 +CONSTANT: CLIPCAPS 36 +CONSTANT: SIZEPALETTE 104 +CONSTANT: NUMRESERVED 106 +CONSTANT: COLORRES 108 +CONSTANT: PHYSICALWIDTH 110 +CONSTANT: PHYSICALHEIGHT 111 +CONSTANT: PHYSICALOFFSETX 112 +CONSTANT: PHYSICALOFFSETY 113 +CONSTANT: SCALINGFACTORX 114 +CONSTANT: SCALINGFACTORY 115 +CONSTANT: VREFRESH 116 +CONSTANT: DESKTOPHORZRES 118 +CONSTANT: DESKTOPVERTRES 117 +CONSTANT: BLTALIGNMENT 119 +CONSTANT: SHADEBLENDCAPS 120 +CONSTANT: SB_NONE HEX: 00 +CONSTANT: SB_CONST_ALPHA HEX: 01 +CONSTANT: SB_PIXEL_ALPHA HEX: 02 +CONSTANT: SB_PREMULT_ALPHA HEX: 04 +CONSTANT: SB_GRAD_RECT HEX: 10 +CONSTANT: SB_GRAD_TRI HEX: 20 +CONSTANT: COLORMGMTCAPS 121 +CONSTANT: CM_NONE HEX: 00 +CONSTANT: CM_DEVICE_ICM HEX: 01 +CONSTANT: CM_GAMMA_RAMP HEX: 02 +CONSTANT: CM_CMYK_COLOR HEX: 04 +CONSTANT: RASTERCAPS 38 +CONSTANT: RC_BITBLT 1 +CONSTANT: RC_BITMAP64 8 +CONSTANT: RC_DI_BITMAP 128 +CONSTANT: RC_DIBTODEV 512 +CONSTANT: RC_FLOODFILL 4096 +CONSTANT: RC_STRETCHBLT 2048 +CONSTANT: RC_STRETCHDIB 8192 +CONSTANT: CURVECAPS 28 +CONSTANT: CC_NONE 0 +CONSTANT: CC_CIRCLES 1 +CONSTANT: CC_PIE 2 +CONSTANT: CC_CHORD 4 +CONSTANT: CC_ELLIPSES 8 +CONSTANT: CC_WIDE 16 +CONSTANT: CC_STYLED 32 +CONSTANT: CC_WIDESTYLED 64 +CONSTANT: CC_INTERIORS 128 +CONSTANT: CC_ROUNDRECT 256 +CONSTANT: LINECAPS 30 +CONSTANT: LC_NONE 0 +CONSTANT: LC_POLYLINE 2 +CONSTANT: LC_MARKER 4 +CONSTANT: LC_POLYMARKER 8 +CONSTANT: LC_WIDE 16 +CONSTANT: LC_STYLED 32 +CONSTANT: LC_WIDESTYLED 64 +CONSTANT: LC_INTERIORS 128 +CONSTANT: POLYGONALCAPS 32 +CONSTANT: RC_BANDING 2 +CONSTANT: RC_BIGFONT 1024 +CONSTANT: RC_DEVBITS HEX: 8000 +CONSTANT: RC_GDI20_OUTPUT 16 +CONSTANT: RC_GDI20_STATE 32 +CONSTANT: RC_NONE 0 +CONSTANT: RC_OP_DX_OUTPUT HEX: 4000 +CONSTANT: RC_PALETTE 256 +CONSTANT: RC_SAVEBITMAP 64 +CONSTANT: RC_SCALING 4 +CONSTANT: PC_NONE 0 +CONSTANT: PC_POLYGON 1 +CONSTANT: PC_POLYPOLYGON 256 +CONSTANT: PC_PATHS 512 +CONSTANT: PC_RECTANGLE 2 +CONSTANT: PC_WINDPOLYGON 4 +CONSTANT: PC_SCANLINE 8 +CONSTANT: PC_TRAPEZOID 4 +CONSTANT: PC_WIDE 16 +CONSTANT: PC_STYLED 32 +CONSTANT: PC_WIDESTYLED 64 +CONSTANT: PC_INTERIORS 128 +CONSTANT: TEXTCAPS 34 +CONSTANT: TC_OP_CHARACTER 1 +CONSTANT: TC_OP_STROKE 2 +CONSTANT: TC_CP_STROKE 4 +CONSTANT: TC_CR_90 8 +CONSTANT: TC_CR_ANY 16 +CONSTANT: TC_SF_X_YINDEP 32 +CONSTANT: TC_SA_DOUBLE 64 +CONSTANT: TC_SA_INTEGER 128 +CONSTANT: TC_SA_CONTIN 256 +CONSTANT: TC_EA_DOUBLE 512 +CONSTANT: TC_IA_ABLE 1024 +CONSTANT: TC_UA_ABLE 2048 +CONSTANT: TC_SO_ABLE 4096 +CONSTANT: TC_RA_ABLE 8192 +CONSTANT: TC_VA_ABLE 16384 +CONSTANT: TC_RESERVED 32768 +CONSTANT: TC_SCROLLBLT 65536 +CONSTANT: GCP_DBCS 1 +CONSTANT: GCP_ERROR HEX: 8000 +CONSTANT: GCP_CLASSIN HEX: 80000 +CONSTANT: GCP_DIACRITIC 256 +CONSTANT: GCP_DISPLAYZWG HEX: 400000 +CONSTANT: GCP_GLYPHSHAPE 16 +CONSTANT: GCP_JUSTIFY HEX: 10000 +CONSTANT: GCP_JUSTIFYIN HEX: 200000 +CONSTANT: GCP_KASHIDA 1024 +CONSTANT: GCP_LIGATE 32 +CONSTANT: GCP_MAXEXTENT HEX: 100000 +CONSTANT: GCP_NEUTRALOVERRIDE HEX: 2000000 +CONSTANT: GCP_NUMERICOVERRIDE HEX: 1000000 +CONSTANT: GCP_NUMERICSLATIN HEX: 4000000 +CONSTANT: GCP_NUMERICSLOCAL HEX: 8000000 +CONSTANT: GCP_REORDER 2 +CONSTANT: GCP_SYMSWAPOFF HEX: 800000 +CONSTANT: GCP_USEKERNING 8 +CONSTANT: FLI_GLYPHS HEX: 40000 +CONSTANT: FLI_MASK HEX: 103b +CONSTANT: GGO_METRICS 0 +CONSTANT: GGO_BITMAP 1 +CONSTANT: GGO_NATIVE 2 +CONSTANT: GGO_BEZIER 3 +CONSTANT: GGO_GRAY2_BITMAP 4 +CONSTANT: GGO_GRAY4_BITMAP 5 +CONSTANT: GGO_GRAY8_BITMAP 6 +CONSTANT: GGO_GLYPH_INDEX 128 +CONSTANT: GGO_UNHINTED 256 +CONSTANT: GM_COMPATIBLE 1 +CONSTANT: GM_ADVANCED 2 +CONSTANT: MM_ANISOTROPIC 8 +CONSTANT: MM_HIENGLISH 5 +CONSTANT: MM_HIMETRIC 3 +CONSTANT: MM_ISOTROPIC 7 +CONSTANT: MM_LOENGLISH 4 +CONSTANT: MM_LOMETRIC 2 +CONSTANT: MM_TEXT 1 +CONSTANT: MM_TWIPS 6 +ALIAS: MM_MAX_FIXEDSCALE MM_TWIPS +CONSTANT: ABSOLUTE 1 +CONSTANT: RELATIVE 2 +CONSTANT: PC_EXPLICIT 2 +CONSTANT: PC_NOCOLLAPSE 4 +CONSTANT: PC_RESERVED 1 +CONSTANT: CLR_NONE HEX: ffffffff +ALIAS: CLR_INVALID CLR_NONE +CONSTANT: CLR_DEFAULT HEX: ff000000 +CONSTANT: PT_MOVETO 6 +CONSTANT: PT_LINETO 2 +CONSTANT: PT_BEZIERTO 4 +CONSTANT: PT_CLOSEFIGURE 1 +CONSTANT: TT_AVAILABLE 1 +CONSTANT: TT_ENABLED 2 +CONSTANT: BLACK_BRUSH 4 +CONSTANT: DKGRAY_BRUSH 3 +CONSTANT: GRAY_BRUSH 2 +CONSTANT: HOLLOW_BRUSH 5 +CONSTANT: LTGRAY_BRUSH 1 +CONSTANT: NULL_BRUSH 5 +CONSTANT: WHITE_BRUSH 0 +CONSTANT: BLACK_PEN 7 +CONSTANT: NULL_PEN 8 +CONSTANT: WHITE_PEN 6 +CONSTANT: ANSI_FIXED_FONT 11 +CONSTANT: ANSI_VAR_FONT 12 +CONSTANT: DEVICE_DEFAULT_FONT 14 +CONSTANT: DEFAULT_GUI_FONT 17 +CONSTANT: OEM_FIXED_FONT 10 +CONSTANT: SYSTEM_FONT 13 +CONSTANT: SYSTEM_FIXED_FONT 16 +CONSTANT: DEFAULT_PALETTE 15 +CONSTANT: DC_BRUSH 18 +CONSTANT: DC_PEN 19 +CONSTANT: SYSPAL_ERROR 0 +CONSTANT: SYSPAL_STATIC 1 +CONSTANT: SYSPAL_NOSTATIC 2 +CONSTANT: SYSPAL_NOSTATIC256 3 +CONSTANT: TA_BASELINE 24 +CONSTANT: TA_BOTTOM 8 +CONSTANT: TA_TOP 0 +CONSTANT: TA_CENTER 6 +CONSTANT: TA_LEFT 0 +CONSTANT: TA_RIGHT 2 +CONSTANT: TA_RTLREADING 256 +CONSTANT: TA_NOUPDATECP 0 +CONSTANT: TA_UPDATECP 1 +: TA_MASK ( -- n ) { TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } flags ; foldable +CONSTANT: VTA_BASELINE 24 +CONSTANT: VTA_CENTER 6 +ALIAS: VTA_LEFT TA_BOTTOM +ALIAS: VTA_RIGHT TA_TOP +ALIAS: VTA_BOTTOM TA_RIGHT +ALIAS: VTA_TOP TA_LEFT +CONSTANT: MWT_IDENTITY 1 +CONSTANT: MWT_LEFTMULTIPLY 2 +CONSTANT: MWT_RIGHTMULTIPLY 3 +CONSTANT: OPAQUE 2 +CONSTANT: TRANSPARENT 1 +CONSTANT: BLACKONWHITE 1 +CONSTANT: WHITEONBLACK 2 +CONSTANT: COLORONCOLOR 3 +CONSTANT: HALFTONE 4 +CONSTANT: MAXSTRETCHBLTMODE 4 +CONSTANT: STRETCH_ANDSCANS 1 +CONSTANT: STRETCH_DELETESCANS 3 +CONSTANT: STRETCH_HALFTONE 4 +CONSTANT: STRETCH_ORSCANS 2 +CONSTANT: TCI_SRCCHARSET 1 +CONSTANT: TCI_SRCCODEPAGE 2 +CONSTANT: TCI_SRCFONTSIG 3 +CONSTANT: ICM_ON 2 +CONSTANT: ICM_OFF 1 +CONSTANT: ICM_QUERY 3 +CONSTANT: NEWFRAME 1 +CONSTANT: ABORTDOC 2 +CONSTANT: NEXTBAND 3 +CONSTANT: SETCOLORTABLE 4 +CONSTANT: GETCOLORTABLE 5 +CONSTANT: FLUSHOUTPUT 6 +CONSTANT: DRAFTMODE 7 +CONSTANT: QUERYESCSUPPORT 8 +CONSTANT: SETABORTPROC 9 +CONSTANT: STARTDOC 10 +CONSTANT: ENDDOC 11 +CONSTANT: GETPHYSPAGESIZE 12 +CONSTANT: GETPRINTINGOFFSET 13 +CONSTANT: GETSCALINGFACTOR 14 +CONSTANT: MFCOMMENT 15 +CONSTANT: GETPENWIDTH 16 +CONSTANT: SETCOPYCOUNT 17 +CONSTANT: SELECTPAPERSOURCE 18 +CONSTANT: DEVICEDATA 19 +CONSTANT: PASSTHROUGH 19 +CONSTANT: GETTECHNOLGY 20 +CONSTANT: GETTECHNOLOGY 20 +CONSTANT: SETLINECAP 21 +CONSTANT: SETLINEJOIN 22 +CONSTANT: SETMITERLIMIT 23 +CONSTANT: BANDINFO 24 +CONSTANT: DRAWPATTERNRECT 25 +CONSTANT: GETVECTORPENSIZE 26 +CONSTANT: GETVECTORBRUSHSIZE 27 +CONSTANT: ENABLEDUPLEX 28 +CONSTANT: GETSETPAPERBINS 29 +CONSTANT: GETSETPRINTORIENT 30 +CONSTANT: ENUMPAPERBINS 31 +CONSTANT: SETDIBSCALING 32 +CONSTANT: EPSPRINTING 33 +CONSTANT: ENUMPAPERMETRICS 34 +CONSTANT: GETSETPAPERMETRICS 35 +CONSTANT: POSTSCRIPT_DATA 37 +CONSTANT: POSTSCRIPT_IGNORE 38 +CONSTANT: MOUSETRAILS 39 +CONSTANT: GETDEVICEUNITS 42 +CONSTANT: GETEXTENDEDTEXTMETRICS 256 +CONSTANT: GETEXTENTTABLE 257 +CONSTANT: GETPAIRKERNTABLE 258 +CONSTANT: GETTRACKKERNTABLE 259 +CONSTANT: EXTTEXTOUT 512 +CONSTANT: GETFACENAME 513 +CONSTANT: DOWNLOADFACE 514 +CONSTANT: ENABLERELATIVEWIDTHS 768 +CONSTANT: ENABLEPAIRKERNING 769 +CONSTANT: SETKERNTRACK 770 +CONSTANT: SETALLJUSTVALUES 771 +CONSTANT: SETCHARSET 772 +CONSTANT: STRETCHBLT 2048 +CONSTANT: GETSETSCREENPARAMS 3072 +CONSTANT: QUERYDIBSUPPORT 3073 +CONSTANT: BEGIN_PATH 4096 +CONSTANT: CLIP_TO_PATH 4097 +CONSTANT: END_PATH 4098 +CONSTANT: EXT_DEVICE_CAPS 4099 +CONSTANT: RESTORE_CTM 4100 +CONSTANT: SAVE_CTM 4101 +CONSTANT: SET_ARC_DIRECTION 4102 +CONSTANT: SET_BACKGROUND_COLOR 4103 +CONSTANT: SET_POLY_MODE 4104 +CONSTANT: SET_SCREEN_ANGLE 4105 +CONSTANT: SET_SPREAD 4106 +CONSTANT: TRANSFORM_CTM 4107 +CONSTANT: SET_CLIP_BOX 4108 +CONSTANT: SET_BOUNDS 4109 +CONSTANT: SET_MIRROR_MODE 4110 +CONSTANT: OPENCHANNEL 4110 +CONSTANT: DOWNLOADHEADER 4111 +CONSTANT: CLOSECHANNEL 4112 +CONSTANT: POSTSCRIPT_PASSTHROUGH 4115 +CONSTANT: ENCAPSULATED_POSTSCRIPT 4116 +CONSTANT: QDI_SETDIBITS 1 +CONSTANT: QDI_GETDIBITS 2 +CONSTANT: QDI_DIBTOSCREEN 4 +CONSTANT: QDI_STRETCHDIB 8 +CONSTANT: SP_NOTREPORTED HEX: 4000 +CONSTANT: PR_JOBSTATUS 0 +CONSTANT: ASPECT_FILTERING 1 +CONSTANT: BS_SOLID 0 +CONSTANT: BS_NULL 1 +CONSTANT: BS_HOLLOW 1 +CONSTANT: BS_HATCHED 2 +CONSTANT: BS_PATTERN 3 +CONSTANT: BS_INDEXED 4 +CONSTANT: BS_DIBPATTERN 5 +CONSTANT: BS_DIBPATTERNPT 6 +CONSTANT: BS_PATTERN8X8 7 +CONSTANT: BS_DIBPATTERN8X8 8 +CONSTANT: LCS_CALIBRATED_RGB 0 +CONSTANT: LCS_DEVICE_RGB 1 +CONSTANT: LCS_DEVICE_CMYK 2 +CONSTANT: LCS_GM_BUSINESS 1 +CONSTANT: LCS_GM_GRAPHICS 2 +CONSTANT: LCS_GM_IMAGES 4 +CONSTANT: RASTER_FONTTYPE 1 +CONSTANT: DEVICE_FONTTYPE 2 +CONSTANT: TRUETYPE_FONTTYPE 4 +CONSTANT: DMORIENT_PORTRAIT 1 +CONSTANT: DMORIENT_LANDSCAPE 2 +CONSTANT: DMPAPER_FIRST 1 +CONSTANT: DMPAPER_LETTER 1 +CONSTANT: DMPAPER_LETTERSMALL 2 +CONSTANT: DMPAPER_TABLOID 3 +CONSTANT: DMPAPER_LEDGER 4 +CONSTANT: DMPAPER_LEGAL 5 +CONSTANT: DMPAPER_STATEMENT 6 +CONSTANT: DMPAPER_EXECUTIVE 7 +CONSTANT: DMPAPER_A3 8 +CONSTANT: DMPAPER_A4 9 +CONSTANT: DMPAPER_A4SMALL 10 +CONSTANT: DMPAPER_A5 11 +CONSTANT: DMPAPER_B4 12 +CONSTANT: DMPAPER_B5 13 +CONSTANT: DMPAPER_FOLIO 14 +CONSTANT: DMPAPER_QUARTO 15 +CONSTANT: DMPAPER_10X14 16 +CONSTANT: DMPAPER_11X17 17 +CONSTANT: DMPAPER_NOTE 18 +CONSTANT: DMPAPER_ENV_9 19 +CONSTANT: DMPAPER_ENV_10 20 +CONSTANT: DMPAPER_ENV_11 21 +CONSTANT: DMPAPER_ENV_12 22 +CONSTANT: DMPAPER_ENV_14 23 +CONSTANT: DMPAPER_CSHEET 24 +CONSTANT: DMPAPER_DSHEET 25 +CONSTANT: DMPAPER_ESHEET 26 +CONSTANT: DMPAPER_ENV_DL 27 +CONSTANT: DMPAPER_ENV_C5 28 +CONSTANT: DMPAPER_ENV_C3 29 +CONSTANT: DMPAPER_ENV_C4 30 +CONSTANT: DMPAPER_ENV_C6 31 +CONSTANT: DMPAPER_ENV_C65 32 +CONSTANT: DMPAPER_ENV_B4 33 +CONSTANT: DMPAPER_ENV_B5 34 +CONSTANT: DMPAPER_ENV_B6 35 +CONSTANT: DMPAPER_ENV_ITALY 36 +CONSTANT: DMPAPER_ENV_MONARCH 37 +CONSTANT: DMPAPER_ENV_PERSONAL 38 +CONSTANT: DMPAPER_FANFOLD_US 39 +CONSTANT: DMPAPER_FANFOLD_STD_GERMAN 40 +CONSTANT: DMPAPER_FANFOLD_LGL_GERMAN 41 +CONSTANT: DMPAPER_ISO_B4 42 +CONSTANT: DMPAPER_JAPANESE_POSTCARD 43 +CONSTANT: DMPAPER_9X11 44 +CONSTANT: DMPAPER_10X11 45 +CONSTANT: DMPAPER_15X11 46 +CONSTANT: DMPAPER_ENV_INVITE 47 +CONSTANT: DMPAPER_RESERVED_48 48 +CONSTANT: DMPAPER_RESERVED_49 49 +CONSTANT: DMPAPER_LETTER_EXTRA 50 +CONSTANT: DMPAPER_LEGAL_EXTRA 51 +CONSTANT: DMPAPER_TABLOID_EXTRA 52 +CONSTANT: DMPAPER_A4_EXTRA 53 +CONSTANT: DMPAPER_LETTER_TRANSVERSE 54 +CONSTANT: DMPAPER_A4_TRANSVERSE 55 +CONSTANT: DMPAPER_LETTER_EXTRA_TRANSVERSE 56 +CONSTANT: DMPAPER_A_PLUS 57 +CONSTANT: DMPAPER_B_PLUS 58 +CONSTANT: DMPAPER_LETTER_PLUS 59 +CONSTANT: DMPAPER_A4_PLUS 60 +CONSTANT: DMPAPER_A5_TRANSVERSE 61 +CONSTANT: DMPAPER_B5_TRANSVERSE 62 +CONSTANT: DMPAPER_A3_EXTRA 63 +CONSTANT: DMPAPER_A5_EXTRA 64 +CONSTANT: DMPAPER_B5_EXTRA 65 +CONSTANT: DMPAPER_A2 66 +CONSTANT: DMPAPER_A3_TRANSVERSE 67 +CONSTANT: DMPAPER_A3_EXTRA_TRANSVERSE 68 +CONSTANT: DMPAPER_DBL_JAPANESE_POSTCARD 69 +CONSTANT: DMPAPER_A6 70 +CONSTANT: DMPAPER_JENV_KAKU2 71 +CONSTANT: DMPAPER_JENV_KAKU3 72 +CONSTANT: DMPAPER_JENV_CHOU3 73 +CONSTANT: DMPAPER_JENV_CHOU4 74 +CONSTANT: DMPAPER_LETTER_ROTATED 75 +CONSTANT: DMPAPER_A3_ROTATED 76 +CONSTANT: DMPAPER_A4_ROTATED 77 +CONSTANT: DMPAPER_A5_ROTATED 78 +CONSTANT: DMPAPER_B4_JIS_ROTATED 79 +CONSTANT: DMPAPER_B5_JIS_ROTATED 80 +CONSTANT: DMPAPER_JAPANESE_POSTCARD_ROTATED 81 +CONSTANT: DMPAPER_DBL_JAPANESE_POSTCARD_ROTATED 82 +CONSTANT: DMPAPER_A6_ROTATED 83 +CONSTANT: DMPAPER_JENV_KAKU2_ROTATED 84 +CONSTANT: DMPAPER_JENV_KAKU3_ROTATED 85 +CONSTANT: DMPAPER_JENV_CHOU3_ROTATED 86 +CONSTANT: DMPAPER_JENV_CHOU4_ROTATED 87 +CONSTANT: DMPAPER_B6_JIS 88 +CONSTANT: DMPAPER_B6_JIS_ROTATED 89 +CONSTANT: DMPAPER_12X11 90 +CONSTANT: DMPAPER_JENV_YOU4 91 +CONSTANT: DMPAPER_JENV_YOU4_ROTATED 92 +CONSTANT: DMPAPER_P16K 93 +CONSTANT: DMPAPER_P32K 94 +CONSTANT: DMPAPER_P32KBIG 95 +CONSTANT: DMPAPER_PENV_1 96 +CONSTANT: DMPAPER_PENV_2 97 +CONSTANT: DMPAPER_PENV_3 98 +CONSTANT: DMPAPER_PENV_4 99 +CONSTANT: DMPAPER_PENV_5 100 +CONSTANT: DMPAPER_PENV_6 101 +CONSTANT: DMPAPER_PENV_7 102 +CONSTANT: DMPAPER_PENV_8 103 +CONSTANT: DMPAPER_PENV_9 104 +CONSTANT: DMPAPER_PENV_10 105 +CONSTANT: DMPAPER_P16K_ROTATED 106 +CONSTANT: DMPAPER_P32K_ROTATED 107 +CONSTANT: DMPAPER_P32KBIG_ROTATED 108 +CONSTANT: DMPAPER_PENV_1_ROTATED 109 +CONSTANT: DMPAPER_PENV_2_ROTATED 110 +CONSTANT: DMPAPER_PENV_3_ROTATED 111 +CONSTANT: DMPAPER_PENV_4_ROTATED 112 +CONSTANT: DMPAPER_PENV_5_ROTATED 113 +CONSTANT: DMPAPER_PENV_6_ROTATED 114 +CONSTANT: DMPAPER_PENV_7_ROTATED 115 +CONSTANT: DMPAPER_PENV_8_ROTATED 116 +CONSTANT: DMPAPER_PENV_9_ROTATED 117 +CONSTANT: DMPAPER_PENV_10_ROTATED 118 +CONSTANT: DMPAPER_LAST 118 +CONSTANT: DMPAPER_USER 256 +CONSTANT: DMBIN_FIRST 1 +CONSTANT: DMBIN_UPPER 1 +CONSTANT: DMBIN_ONLYONE 1 +CONSTANT: DMBIN_LOWER 2 +CONSTANT: DMBIN_MIDDLE 3 +CONSTANT: DMBIN_MANUAL 4 +CONSTANT: DMBIN_ENVELOPE 5 +CONSTANT: DMBIN_ENVMANUAL 6 +CONSTANT: DMBIN_AUTO 7 +CONSTANT: DMBIN_TRACTOR 8 +CONSTANT: DMBIN_SMALLFMT 9 +CONSTANT: DMBIN_LARGEFMT 10 +CONSTANT: DMBIN_LARGECAPACITY 11 +CONSTANT: DMBIN_CASSETTE 14 +CONSTANT: DMBIN_FORMSOURCE 15 +CONSTANT: DMBIN_LAST 15 +CONSTANT: DMBIN_USER 256 +CONSTANT: DMRES_DRAFT -1 +CONSTANT: DMRES_LOW -2 +CONSTANT: DMRES_MEDIUM -3 +CONSTANT: DMRES_HIGH -4 +CONSTANT: DMCOLOR_MONOCHROME 1 +CONSTANT: DMCOLOR_COLOR 2 +CONSTANT: DMDUP_SIMPLEX 1 +CONSTANT: DMDUP_VERTICAL 2 +CONSTANT: DMDUP_HORIZONTAL 3 +CONSTANT: DMTT_BITMAP 1 +CONSTANT: DMTT_DOWNLOAD 2 +CONSTANT: DMTT_SUBDEV 3 +CONSTANT: DMTT_DOWNLOAD_OUTLINE 4 +CONSTANT: DMCOLLATE_FALSE 0 +CONSTANT: DMCOLLATE_TRUE 1 +CONSTANT: DM_SPECVERSION 800 +CONSTANT: DM_GRAYSCALE 1 +CONSTANT: DM_INTERLACED 2 +CONSTANT: DM_UPDATE 1 +CONSTANT: DM_COPY 2 +CONSTANT: DM_PROMPT 4 +CONSTANT: DM_MODIFY 8 +ALIAS: DM_IN_BUFFER DM_MODIFY +ALIAS: DM_IN_PROMPT DM_PROMPT +ALIAS: DM_OUT_BUFFER DM_COPY +ALIAS: DM_OUT_DEFAULT DM_UPDATE +CONSTANT: DM_ORIENTATION HEX: 00000001 +CONSTANT: DM_PAPERSIZE HEX: 00000002 +CONSTANT: DM_PAPERLENGTH HEX: 00000004 +CONSTANT: DM_PAPERWIDTH HEX: 00000008 +CONSTANT: DM_SCALE HEX: 00000010 +CONSTANT: DM_POSITION HEX: 00000020 +CONSTANT: DM_COPIES HEX: 00000100 +CONSTANT: DM_DEFAULTSOURCE HEX: 00000200 +CONSTANT: DM_PRINTQUALITY HEX: 00000400 +CONSTANT: DM_COLOR HEX: 00000800 +CONSTANT: DM_DUPLEX HEX: 00001000 +CONSTANT: DM_YRESOLUTION HEX: 00002000 +CONSTANT: DM_TTOPTION HEX: 00004000 +CONSTANT: DM_COLLATE HEX: 00008000 +CONSTANT: DM_FORMNAME HEX: 00010000 +CONSTANT: DM_LOGPIXELS HEX: 00020000 +CONSTANT: DM_BITSPERPEL HEX: 00040000 +CONSTANT: DM_PELSWIDTH HEX: 00080000 +CONSTANT: DM_PELSHEIGHT HEX: 00100000 +CONSTANT: DM_DISPLAYFLAGS HEX: 00200000 +CONSTANT: DM_DISPLAYFREQUENCY HEX: 00400000 +CONSTANT: DM_ICMMETHOD HEX: 00800000 +CONSTANT: DM_ICMINTENT HEX: 01000000 +CONSTANT: DM_MEDIATYPE HEX: 02000000 +CONSTANT: DM_DITHERTYPE HEX: 04000000 +CONSTANT: DM_PANNINGWIDTH HEX: 08000000 +CONSTANT: DM_PANNINGHEIGHT HEX: 10000000 +CONSTANT: DM_DISPLAYFIXEDOUTPUT HEX: 20000000 +CONSTANT: DM_DISPLAYORIENTATION HEX: 00000080 +CONSTANT: DMDO_DEFAULT HEX: 00000000 +CONSTANT: DMDO_90 HEX: 00000001 +CONSTANT: DMDO_180 HEX: 00000002 +CONSTANT: DMDO_270 HEX: 00000003 +CONSTANT: DMDFO_DEFAULT HEX: 00000000 +CONSTANT: DMDFO_STRETCH HEX: 00000001 +CONSTANT: DMDFO_CENTER HEX: 00000002 +CONSTANT: DMICMMETHOD_NONE 1 +CONSTANT: DMICMMETHOD_SYSTEM 2 +CONSTANT: DMICMMETHOD_DRIVER 3 +CONSTANT: DMICMMETHOD_DEVICE 4 +CONSTANT: DMICMMETHOD_USER 256 +CONSTANT: DMICM_SATURATE 1 +CONSTANT: DMICM_CONTRAST 2 +CONSTANT: DMICM_COLORMETRIC 3 +CONSTANT: DMICM_USER 256 +CONSTANT: DMMEDIA_STANDARD 1 +CONSTANT: DMMEDIA_TRANSPARENCY 2 +CONSTANT: DMMEDIA_GLOSSY 3 +CONSTANT: DMMEDIA_USER 256 +CONSTANT: DMDITHER_NONE 1 +CONSTANT: DMDITHER_COARSE 2 +CONSTANT: DMDITHER_FINE 3 +CONSTANT: DMDITHER_LINEART 4 +CONSTANT: DMDITHER_ERRORDIFFUSION 5 +CONSTANT: DMDITHER_RESERVED6 6 +CONSTANT: DMDITHER_RESERVED7 7 +CONSTANT: DMDITHER_RESERVED8 8 +CONSTANT: DMDITHER_RESERVED9 9 +CONSTANT: DMDITHER_GRAYSCALE 10 +CONSTANT: DMDITHER_USER 256 +CONSTANT: GDI_ERROR HEX: FFFFFFFF +: HGDI_ERROR ( -- alien ) GDI_ERROR ; inline +CONSTANT: TMPF_FIXED_PITCH 1 +CONSTANT: TMPF_VECTOR 2 +CONSTANT: TMPF_TRUETYPE 4 +CONSTANT: TMPF_DEVICE 8 +CONSTANT: NTM_ITALIC 1 +CONSTANT: NTM_BOLD 32 +CONSTANT: NTM_REGULAR 64 +CONSTANT: TT_POLYGON_TYPE 24 +CONSTANT: TT_PRIM_LINE 1 +CONSTANT: TT_PRIM_QSPLINE 2 +CONSTANT: TT_PRIM_CSPLINE 3 +CONSTANT: FONTMAPPER_MAX 10 +CONSTANT: ENHMETA_STOCK_OBJECT HEX: 80000000 +CONSTANT: WGL_FONT_LINES 0 +CONSTANT: WGL_FONT_POLYGONS 1 +CONSTANT: LPD_DOUBLEBUFFER 1 +CONSTANT: LPD_STEREO 2 +CONSTANT: LPD_SUPPORT_GDI 16 +CONSTANT: LPD_SUPPORT_OPENGL 32 +CONSTANT: LPD_SHARE_DEPTH 64 +CONSTANT: LPD_SHARE_STENCIL 128 +CONSTANT: LPD_SHARE_ACCUM 256 +CONSTANT: LPD_SWAP_EXCHANGE 512 +CONSTANT: LPD_SWAP_COPY 1024 +CONSTANT: LPD_TRANSPARENT 4096 +CONSTANT: LPD_TYPE_RGBA 0 +CONSTANT: LPD_TYPE_COLORINDEX 1 +CONSTANT: WGL_SWAP_MAIN_PLANE 1 +CONSTANT: WGL_SWAP_OVERLAY1 2 +CONSTANT: WGL_SWAP_OVERLAY2 4 +CONSTANT: WGL_SWAP_OVERLAY3 8 +CONSTANT: WGL_SWAP_OVERLAY4 16 +CONSTANT: WGL_SWAP_OVERLAY5 32 +CONSTANT: WGL_SWAP_OVERLAY6 64 +CONSTANT: WGL_SWAP_OVERLAY7 128 +CONSTANT: WGL_SWAP_OVERLAY8 256 +CONSTANT: WGL_SWAP_OVERLAY9 512 +CONSTANT: WGL_SWAP_OVERLAY10 1024 +CONSTANT: WGL_SWAP_OVERLAY11 2048 +CONSTANT: WGL_SWAP_OVERLAY12 4096 +CONSTANT: WGL_SWAP_OVERLAY13 8192 +CONSTANT: WGL_SWAP_OVERLAY14 16384 +CONSTANT: WGL_SWAP_OVERLAY15 32768 +CONSTANT: WGL_SWAP_UNDERLAY1 65536 +CONSTANT: WGL_SWAP_UNDERLAY2 HEX: 20000 +CONSTANT: WGL_SWAP_UNDERLAY3 HEX: 40000 +CONSTANT: WGL_SWAP_UNDERLAY4 HEX: 80000 +CONSTANT: WGL_SWAP_UNDERLAY5 HEX: 100000 +CONSTANT: WGL_SWAP_UNDERLAY6 HEX: 200000 +CONSTANT: WGL_SWAP_UNDERLAY7 HEX: 400000 +CONSTANT: WGL_SWAP_UNDERLAY8 HEX: 800000 +CONSTANT: WGL_SWAP_UNDERLAY9 HEX: 1000000 +CONSTANT: WGL_SWAP_UNDERLAY10 HEX: 2000000 +CONSTANT: WGL_SWAP_UNDERLAY11 HEX: 4000000 +CONSTANT: WGL_SWAP_UNDERLAY12 HEX: 8000000 +CONSTANT: WGL_SWAP_UNDERLAY13 HEX: 10000000 +CONSTANT: WGL_SWAP_UNDERLAY14 HEX: 20000000 +CONSTANT: WGL_SWAP_UNDERLAY15 HEX: 40000000 +CONSTANT: AC_SRC_OVER HEX: 00 +CONSTANT: AC_SRC_ALPHA HEX: 01 +CONSTANT: AC_SRC_NO_PREMULT_ALPHA HEX: 01 +CONSTANT: AC_SRC_NO_ALPHA HEX: 02 +CONSTANT: AC_DST_NO_PREMULT_ALPHA HEX: 10 +CONSTANT: AC_DST_NO_ALPHA HEX: 20 +CONSTANT: LAYOUT_RTL 1 +CONSTANT: LAYOUT_BITMAPORIENTATIONPRESERVED 8 +CONSTANT: CS_ENABLE HEX: 00000001 +CONSTANT: CS_DISABLE HEX: 00000002 +CONSTANT: CS_DELETE_TRANSFORM HEX: 00000003 +CONSTANT: GRADIENT_FILL_RECT_H HEX: 00 +CONSTANT: GRADIENT_FILL_RECT_V HEX: 01 +CONSTANT: GRADIENT_FILL_TRIANGLE HEX: 02 +CONSTANT: GRADIENT_FILL_OP_FLAG HEX: ff +CONSTANT: COLORMATCHTOTARGET_EMBEDED HEX: 00000001 +CONSTANT: CREATECOLORSPACE_EMBEDED HEX: 00000001 +CONSTANT: SETICMPROFILE_EMBEDED HEX: 00000001 + +CONSTANT: DISPLAY_DEVICE_ATTACHED_TO_DESKTOP HEX: 00000001 +CONSTANT: DISPLAY_DEVICE_MULTI_DRIVER HEX: 00000002 +CONSTANT: DISPLAY_DEVICE_PRIMARY_DEVICE HEX: 00000004 +CONSTANT: DISPLAY_DEVICE_MIRRORING_DRIVER HEX: 00000008 +CONSTANT: DISPLAY_DEVICE_VGA_COMPATIBLE HEX: 00000010 +CONSTANT: DISPLAY_DEVICE_REMOVABLE HEX: 00000020 +CONSTANT: DISPLAY_DEVICE_MODESPRUNED HEX: 08000000 + +CONSTANT: NTM_NONNEGATIVE_AC HEX: 00010000 +CONSTANT: NTM_PS_OPENTYPE HEX: 00020000 +CONSTANT: NTM_TT_OPENTYPE HEX: 00040000 +CONSTANT: NTM_MULTIPLEMASTER HEX: 00080000 +CONSTANT: NTM_TYPE1 HEX: 00100000 +CONSTANT: NTM_DSIG HEX: 00200000 + +CONSTANT: GGI_MARK_NONEXISTING_GLYPHS 1 LIBRARY: gdi32 @@ -100,7 +1335,8 @@ FUNCTION: HBITMAP CreateDIBSection ( HDC hdc, BITMAPINFO* pbmi, UINT iUsage, voi ! FUNCTION: CreateFontIndirectExA ! FUNCTION: CreateFontIndirectExW ! FUNCTION: CreateFontIndirectW -! FUNCTION: CreateFontW +FUNCTION: HFONT CreateFontW ( int nHeight, int nWidth, int nEscapement, int nOrientation, int fnWeight, DWORD fdwItalic, DWORD fdwUnderline, DWORD fdwStrikeOut, DWORD fdwCharSet, DWORD fdwOutputPrecision, DWORD fdwClipPrecision, DWORD fdwQuality, DWORD fdwPitchAndFamily, LPCTSTR lpszFace ) ; +ALIAS: CreateFont CreateFontW ! FUNCTION: CreateHalftonePalette ! FUNCTION: CreateHatchBrush ! FUNCTION: CreateICA @@ -262,7 +1498,8 @@ DESTRUCTOR: DeleteObject ! FUNCTION: ExtFloodFill ! FUNCTION: ExtSelectClipRgn ! FUNCTION: ExtTextOutA -! FUNCTION: ExtTextOutW +FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ; +ALIAS: ExtTextOut ExtTextOutW ! FUNCTION: FillPath ! FUNCTION: FillRgn ! FUNCTION: FixBrushOrgEx @@ -486,7 +1723,8 @@ FUNCTION: HGDIOBJ GetStockObject ( int fnObject ) ; ! FUNCTION: GetTextFaceAliasW ! FUNCTION: GetTextFaceW ! FUNCTION: GetTextMetricsA -! FUNCTION: GetTextMetricsW +FUNCTION: BOOL GetTextMetricsW ( HDC hdc, LPTEXTMETRIC lptm ) ; +ALIAS: GetTextMetrics GetTextMetricsW ! FUNCTION: GetTransform ! FUNCTION: GetViewportExtEx ! FUNCTION: GetViewportOrgEx @@ -569,15 +1807,15 @@ FUNCTION: HGDIOBJ SelectObject ( HDC hdc, HGDIOBJ hgdiobj ) ; ! FUNCTION: SetBitmapAttributes ! FUNCTION: SetBitmapBits ! FUNCTION: SetBitmapDimensionEx -! FUNCTION: SetBkColor +FUNCTION: COLORREF SetBkColor ( HDC hdc, COLORREF color ) ; ! FUNCTION: SetBkMode ! FUNCTION: SetBoundsRect ! FUNCTION: SetBrushAttributes ! FUNCTION: SetBrushOrgEx ! FUNCTION: SetColorAdjustment ! FUNCTION: SetColorSpace -! FUNCTION: SetDCBrushColor -! FUNCTION: SetDCPenColor +FUNCTION: COLORREF SetDCBrushColor ( HDC hdc, COLORREF color ) ; +FUNCTION: COLORREF SetDCPenColor ( HDC hdc, COLORREF color ) ; ! FUNCTION: SetDeviceGammaRamp ! FUNCTION: SetDIBColorTable ! FUNCTION: SetDIBits @@ -608,7 +1846,8 @@ FUNCTION: BOOL SetPixelFormat ( HDC hDC, int iPixelFormat, PFD* ppfd ) ; ! FUNCTION: SetSystemPaletteUse ! FUNCTION: SetTextAlign ! FUNCTION: SetTextCharacterExtra -! FUNCTION: SetTextColor +FUNCTION: COLORREF SetTextColor ( HDC hdc, COLORREF crColor ) ; +! FUNCTION: SetTextColor ( HDC hDC, ! FUNCTION: SetTextJustification ! FUNCTION: SetViewportExtEx ! FUNCTION: SetViewportOrgEx diff --git a/basis/windows/offscreen/offscreen-tests.factor b/basis/windows/offscreen/offscreen-tests.factor new file mode 100755 index 0000000000..58273979b7 --- /dev/null +++ b/basis/windows/offscreen/offscreen-tests.factor @@ -0,0 +1,5 @@ +IN: windows.offscreen.tests +USING: windows.offscreen effects tools.test kernel images ; + +{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as +[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test diff --git a/basis/windows/offscreen/offscreen.factor b/basis/windows/offscreen/offscreen.factor old mode 100644 new mode 100755 index 4eee68c37a..6e65958220 --- a/basis/windows/offscreen/offscreen.factor +++ b/basis/windows/offscreen/offscreen.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel combinators sequences math windows.gdi32 windows.types images destructors -accessors fry ; +accessors fry locals ; IN: windows.offscreen : (bitmap-info) ( dim -- BITMAPINFO ) @@ -22,26 +22,32 @@ IN: windows.offscreen } 2cleave ] keep ; -: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits ) - f CreateCompatibleDC +: make-bitmap ( dim dc -- hBitmap bits ) [ nip ] [ swap (bitmap-info) DIB_RGB_COLORS f [ f 0 CreateDIBSection ] keep *void* ] 2bi - [ 2dup SelectObject drop ] dip ; + [ [ SelectObject drop ] keep ] dip ; + +: make-offscreen-dc-and-bitmap ( dim -- dc hBitmap bits ) + [ f CreateCompatibleDC ] dip over make-bitmap ; : bitmap>byte-array ( bits dim -- byte-array ) product 4 * memory>byte-array ; : bitmap>image ( bits dim -- image ) [ bitmap>byte-array ] keep - swap >>dim swap >>bitmap XBGR >>component-order ; + + swap >>dim + swap >>bitmap + BGRX >>component-order + t >>upside-down? ; -: make-bitmap-image ( dim quot: ( hDC -- ) -- image ) - '[ - [ - make-offscreen-dc-and-bitmap - [ &DeleteDC @ ] [ &DeleteObject drop ] [ ] tri* - ] keep bitmap>byte-array - ] with-destructors ; inline \ No newline at end of file +: with-memory-dc ( quot: ( hDC -- ) -- ) + [ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline + +:: make-bitmap-image ( dim dc quot -- image ) + dim dc make-bitmap [ &DeleteObject drop ] dip + quot dip + dim bitmap>image ; inline \ No newline at end of file diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index ee74e47fea..20bae06f30 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax namespaces kernel words ; +USING: alien alien.c-types alien.syntax namespaces kernel words +sequences math math.bitwise math.vectors colors ; IN: windows.types TYPEDEF: char CHAR @@ -244,14 +245,14 @@ C-STRUCT: RECT { "LONG" "right" } { "LONG" "bottom" } ; -! C-STRUCT: PAINTSTRUCT - ! { "HDC" " hdc" } - ! { "BOOL" "fErase" } - ! { "RECT" "rcPaint" } - ! { "BOOL" "fRestore" } - ! { "BOOL" "fIncUpdate" } - ! { "BYTE[32]" "rgbReserved" } -! ; +C-STRUCT: PAINTSTRUCT + { "HDC" " hdc" } + { "BOOL" "fErase" } + { "RECT" "rcPaint" } + { "BOOL" "fRestore" } + { "BOOL" "fIncUpdate" } + { "BYTE[32]" "rgbReserved" } +; C-STRUCT: BITMAPINFOHEADER { "DWORD" "biSize" } @@ -283,6 +284,10 @@ C-STRUCT: POINT { "LONG" "x" } { "LONG" "y" } ; +C-STRUCT: SIZE + { "LONG" "cx" } + { "LONG" "cy" } ; + C-STRUCT: MSG { "HWND" "hWnd" } { "UINT" "message" } @@ -327,6 +332,14 @@ C-STRUCT: RECT { "LONG" "right" } { "LONG" "bottom" } ; +: ( loc dim -- RECT ) + over v+ + "RECT" + over first over set-RECT-right + swap second over set-RECT-bottom + over first over set-RECT-left + swap second over set-RECT-top ; + TYPEDEF: RECT* PRECT TYPEDEF: RECT* LPRECT TYPEDEF: PIXELFORMATDESCRIPTOR PFD @@ -363,3 +376,36 @@ C-STRUCT: ACCEL { "WORD" "key" } { "WORD" "cmd" } ; TYPEDEF: ACCEL* LPACCEL + +TYPEDEF: DWORD COLORREF +TYPEDEF: DWORD* LPCOLORREF + +: RGB ( r g b -- COLORREF ) + { 16 8 0 } bitfield ; inline + +: color>RGB ( color -- COLORREF ) + >rgba-components drop [ 255 * >integer ] tri@ RGB ; + +C-STRUCT: TEXTMETRICW + { "LONG" "tmHeight" } + { "LONG" "tmAscent" } + { "LONG" "tmDescent" } + { "LONG" "tmInternalLeading" } + { "LONG" "tmExternalLeading" } + { "LONG" "tmAveCharWidth" } + { "LONG" "tmMaxCharWidth" } + { "LONG" "tmWeight" } + { "LONG" "tmOverhang" } + { "LONG" "tmDigitizedAspectX" } + { "LONG" "tmDigitizedAspectY" } + { "WCHAR" "tmFirstChar" } + { "WCHAR" "tmLastChar" } + { "WCHAR" "tmDefaultChar" } + { "WCHAR" "tmBreakChar" } + { "BYTE" "tmItalic" } + { "BYTE" "tmUnderlined" } + { "BYTE" "tmStruckOut" } + { "BYTE" "tmPitchAndFamily" } + { "BYTE" "tmCharSet" } ; + +TYPEDEF: TEXTMETRICW* LPTEXTMETRIC diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor old mode 100644 new mode 100755 index 5d24601555..cfd723ae8f --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -1,65 +1,95 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences io.encodings.string io.encodings.utf16n -accessors arrays destructors alien.c-types windows windows.usp10 -windows.offscreen ; +USING: kernel assocs math sequences fry io.encodings.string +io.encodings.utf16n accessors arrays combinators destructors +cache namespaces init images.normalization alien.c-types locals +windows windows.usp10 windows.offscreen windows.gdi32 +windows.ole32 windows.types windows.fonts ; IN: windows.uniscribe -TUPLE: script-string pssa size image ; +TUPLE: script-string metrics ssa size image string disposed ; : make-script-string ( dc string -- script-string ) [ utf16n encode ] ! pString [ length ] bi ! cString - dup 1.5 * 16 + ! cGlyphs -- MSDN says this is "recommended size" + dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size" -1 ! iCharset -- Unicode SSA_GLYPHS ! dwFlags - ... ! iReqWidth + 0 ! iReqWidth f ! psControl f ! psState f ! piDx f ! pTabdef - ... ! pbInClass + f ! pbInClass f ! pssa [ ScriptStringAnalyse ] keep - [ win32-error=0/f ] [ |ScriptStringFree ] bi* ; + [ ole32-error ] [ |ScriptStringFree *void* ] bi* ; -: draw-script-string ( script-string -- bitmap ) +: draw-script-string ( script-string -- ) ! ssa 0 ! iX 0 ! iY - ETO_OPAQUE ! uOptions ... ???? + 0 ! uOptions f ! prc 0 ! iMinSel 0 ! iMaxSel - f ! fDisabled - ScriptStringOut ; + FALSE ! fDisabled + ScriptStringOut ole32-error ; -: ( string -- script-string ) - [ - ... dim ... [ - make-script-string |ScriptStringFree - [ ] - [ draw-script-string ] - [ - ScriptString_pSize - dup win32-error=0/f - [ SIZE-cx ] [ SIZE-cy ] bi 2array - ] tri - ] make-bitmap-image - script-string boa - ] with-destructors ; +: set-dc-font ( dc font -- ) + [ cache-font SelectObject win32-error=0/f ] + [ background>> color>RGB SetBkColor drop ] + [ foreground>> color>RGB SetTextColor drop ] 2tri ; -M: script-string dispose* pssa>> ScriptStringFree win32-error=0/f ; +: script-string-size ( ssa -- dim ) + ScriptString_pSize + dup win32-error=0/f + [ SIZE-cx ] [ SIZE-cy ] bi 2array ; -: line-offset>x ( offset script-string -- x ) - pssa>> ! ssa - swap ! icp - ... ! fTrailing - 0 [ ScriptStringCPtoX win32-error=0/f ] keep *int ; +: dc-metrics ( dc -- metrics ) + "TEXTMETRICW" [ GetTextMetrics drop ] keep + TEXTMETRIC>metrics ; -: line-x>offset ( x script-string -- offset trailing ) - pssa>> ! ssa +:: ( font string -- script-string ) + #! Comments annotate BOA constructor arguments + [| dc | + dc font set-dc-font + dc dc-metrics ! metrics + dc string make-script-string dup :> ssa ! ssa + dup script-string-size ! size + dup dc [ ssa draw-script-string ] make-bitmap-image + normalize-image ! image + string ! string + f script-string boa + ] with-memory-dc ; + +: text-position ( script-string -- loc ) drop { 0 0 } ; + +M: script-string dispose* ssa>> ScriptStringFree ole32-error ; + +SYMBOL: cached-script-strings + +: cached-script-string ( string font -- script-string ) + cached-script-strings get-global [ ] 2cache ; + +[ cached-script-strings set-global ] +"windows.uniscribe" add-init-hook + +: line-offset>x ( n script-string -- x ) + 2dup string>> length = [ + ssa>> ! ssa + swap 1- ! icp + TRUE ! fTrailing + ] [ + ssa>> + swap ! icp + FALSE ! fTrailing + ] if + 0 [ ScriptStringCPtoX ole32-error ] keep *int ; + +: x>line-offset ( x script-string -- n trailing ) + ssa>> ! ssa swap ! iX 0 ! pCh 0 ! piTrailing - [ ScriptStringXtoCP win32-error=0/f ] 2keep [ *int ] bi@ ; \ No newline at end of file + [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ; \ No newline at end of file From dba42f92593b441f6c6cffac5d9e404adf578a20 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Thu, 2 Apr 2009 13:07:45 -0500 Subject: [PATCH 09/73] Remove DLL-downloading logic since we don't have external deps anymore --- basis/tools/deploy/windows/windows.factor | 9 +-------- build-support/dlls.txt | 12 ------------ build-support/factor.sh | 12 ------------ extra/mason/child/child.factor | 14 +------------- 4 files changed, 2 insertions(+), 45 deletions(-) delete mode 100644 build-support/dlls.txt mode change 100644 => 100755 extra/mason/child/child.factor diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index bfa096ad2f..f21f4ac363 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -9,11 +9,6 @@ IN: tools.deploy.windows : copy-dll ( bundle-name -- ) "resource:factor.dll" swap copy-file-into ; -: copy-pango ( bundle-name -- ) - "resource:build-support/dlls.txt" ascii file-lines - [ "resource:" prepend-path ] map - swap copy-files-into ; - :: copy-vm ( executable bundle-name extension -- vm ) vm "." split1-last drop extension append bundle-name executable ".exe" append append-path @@ -22,9 +17,7 @@ IN: tools.deploy.windows : create-exe-dir ( vocab bundle-name -- vm ) dup copy-dll deploy-ui? get [ - [ copy-pango ] - [ "" copy-theme ] - [ ".exe" copy-vm ] tri + [ "" copy-theme ] [ ".exe" copy-vm ] bi ] [ ".com" copy-vm ] if ; M: winnt deploy* diff --git a/build-support/dlls.txt b/build-support/dlls.txt deleted file mode 100644 index 97d0cf6e9c..0000000000 --- a/build-support/dlls.txt +++ /dev/null @@ -1,12 +0,0 @@ -libcairo-2.dll -libgio-2.0-0.dll -libglib-2.0-0.dll -libgmodule-2.0-0.dll -libgobject-2.0-0.dll -libgthread-2.0-0.dll -libpango-1.0-0.dll -libpangocairo-1.0-0.dll -libpangowin32-1.0-0.dll -libpng12-0.dll -libtiff3.dll -zlib1.dll diff --git a/build-support/factor.sh b/build-support/factor.sh index 61450dacb4..ad64c541fe 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -445,16 +445,6 @@ get_url() { check_ret $DOWNLOADER } -maybe_download_dlls() { - if [[ $OS == winnt ]] ; then - for file in `cat build-support/dlls.txt`; do - get_url http://factorcode.org/dlls/$file - chmod 777 *.dll - check_ret chmod - done - fi -} - get_config_info() { find_build_info check_installed_programs @@ -472,7 +462,6 @@ install() { cd_factor make_factor get_boot_image - maybe_download_dlls bootstrap } @@ -547,7 +536,6 @@ case "$1" in update) update; update_bootstrap ;; bootstrap) get_config_info; bootstrap ;; report) find_build_info ;; - dlls) get_config_info; maybe_download_dlls;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;; make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;; *) usage ;; diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor old mode 100644 new mode 100755 index 04c4a09f61..2ed9226524 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays calendar combinators.short-circuit -continuations debugger http.client io.directories io.files io.launcher +continuations debugger io.directories io.files io.launcher io.pathnames io.encodings.ascii kernel make mason.common mason.config mason.platform mason.report mason.email namespaces sequences ; IN: mason.child @@ -9,20 +9,8 @@ IN: mason.child : make-cmd ( -- args ) gnu-make platform 2array ; -: dll-url ( -- url ) - "http://factorcode.org/dlls/" - target-cpu get "x86.64" = [ "64/" append ] when ; - -: download-dlls ( -- ) - target-os get "winnt" = [ - dll-url "build-support/dlls.txt" ascii file-lines - [ append download ] with each - ] when ; - : make-vm ( -- ) "factor" [ - download-dlls - make-cmd >>command "../compile-log" >>stdout From 2c556fbb655f6aa93f83994671a9e5ca34e352e2 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Thu, 2 Apr 2009 13:11:06 -0500 Subject: [PATCH 10/73] Better error message printout in extra/descriptive --- extra/descriptive/descriptive.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index ba3438e37d..ceadc9fe6e 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -1,13 +1,16 @@ USING: words kernel sequences locals locals.parser locals.definitions accessors parser namespaces continuations -summary definitions generalizations arrays ; +summary definitions generalizations arrays prettyprint debugger io ; IN: descriptive ERROR: descriptive-error args underlying word ; -M: descriptive-error summary - word>> "The " swap name>> " word encountered an error." - 3append ; +M: descriptive-error error. + "The word " write dup word>> pprint " encountered an error." print + "Arguments:" print + dup args>> stack. + "Error:" print + underlying>> error. ; Date: Thu, 2 Apr 2009 13:24:34 -0500 Subject: [PATCH 11/73] Fix Uniscribe font size --- basis/windows/fonts/fonts.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor index b9fb48d840..a034856b34 100755 --- a/basis/windows/fonts/fonts.factor +++ b/basis/windows/fonts/fonts.factor @@ -1,4 +1,4 @@ -USING: assocs memoize locals kernel accessors init fonts +USING: assocs memoize locals kernel accessors init fonts math combinators windows windows.types windows.gdi32 ; IN: windows.fonts @@ -10,7 +10,7 @@ IN: windows.fonts } at-default ; MEMO:: (cache-font) ( font -- HFONT ) - font size>> ! nHeight + font size>> neg ! nHeight 0 0 0 ! nWidth, nEscapement, nOrientation font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight font italic?>> TRUE FALSE ? ! fdwItalic From e0a8def090a8ec4bfd0f51c02072f0e910c2165c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 2 Apr 2009 13:48:53 -0500 Subject: [PATCH 12/73] Fix generate-help to not open thousands of windows in UI --- basis/help/html/html.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 66d864b2a0..d880af5b55 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -60,7 +60,7 @@ M: topic url-of topic>filename ; : help>html ( topic -- xml ) [ article-title ] [ drop help-stylesheet ] - [ [ help ] with-html-writer ] + [ [ print-topic ] with-html-writer ] tri simple-page ; : generate-help-file ( topic -- ) From dfa27e0c174b0beda5fc8f1d613e4f878335de8a Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Thu, 2 Apr 2009 13:50:15 -0500 Subject: [PATCH 13/73] Add vocab meta-data for some of the new vocabs --- basis/ui/text/pango/summary.txt | 1 + basis/ui/text/uniscribe/authors.txt | 1 + basis/ui/text/uniscribe/summary.txt | 1 + basis/ui/text/uniscribe/tags.txt | 1 + basis/windows/offscreen/summary.txt | 1 + basis/windows/offscreen/tags.txt | 1 + basis/windows/uniscribe/summary.txt | 1 + basis/windows/uniscribe/tags.txt | 1 + 8 files changed, 8 insertions(+) create mode 100755 basis/ui/text/pango/summary.txt create mode 100755 basis/ui/text/uniscribe/authors.txt create mode 100755 basis/ui/text/uniscribe/summary.txt create mode 100755 basis/ui/text/uniscribe/tags.txt create mode 100755 basis/windows/offscreen/summary.txt create mode 100755 basis/windows/offscreen/tags.txt create mode 100755 basis/windows/uniscribe/summary.txt create mode 100755 basis/windows/uniscribe/tags.txt diff --git a/basis/ui/text/pango/summary.txt b/basis/ui/text/pango/summary.txt new file mode 100755 index 0000000000..0e2e18c9d3 --- /dev/null +++ b/basis/ui/text/pango/summary.txt @@ -0,0 +1 @@ +UI text rendering implementation using cross-platform Pango library diff --git a/basis/ui/text/uniscribe/authors.txt b/basis/ui/text/uniscribe/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/basis/ui/text/uniscribe/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/ui/text/uniscribe/summary.txt b/basis/ui/text/uniscribe/summary.txt new file mode 100755 index 0000000000..2480a4e98b --- /dev/null +++ b/basis/ui/text/uniscribe/summary.txt @@ -0,0 +1 @@ +UI text rendering implementation using MS Windows Uniscribe library diff --git a/basis/ui/text/uniscribe/tags.txt b/basis/ui/text/uniscribe/tags.txt new file mode 100755 index 0000000000..6abe115b12 --- /dev/null +++ b/basis/ui/text/uniscribe/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/offscreen/summary.txt b/basis/windows/offscreen/summary.txt new file mode 100755 index 0000000000..dd7040564e --- /dev/null +++ b/basis/windows/offscreen/summary.txt @@ -0,0 +1 @@ +Utility words for memory DCs and bitmaps diff --git a/basis/windows/offscreen/tags.txt b/basis/windows/offscreen/tags.txt new file mode 100755 index 0000000000..6abe115b12 --- /dev/null +++ b/basis/windows/offscreen/tags.txt @@ -0,0 +1 @@ +unportable diff --git a/basis/windows/uniscribe/summary.txt b/basis/windows/uniscribe/summary.txt new file mode 100755 index 0000000000..7b71cf1fc9 --- /dev/null +++ b/basis/windows/uniscribe/summary.txt @@ -0,0 +1 @@ +High-level wrapper around Uniscribe binding diff --git a/basis/windows/uniscribe/tags.txt b/basis/windows/uniscribe/tags.txt new file mode 100755 index 0000000000..6abe115b12 --- /dev/null +++ b/basis/windows/uniscribe/tags.txt @@ -0,0 +1 @@ +unportable From 7e0f271cf3f4eb428aa40a85369b54b338585572 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 2 Apr 2009 17:00:29 -0500 Subject: [PATCH 14/73] fix typo in docs --- basis/math/functions/functions.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 799bb04169..1eac321e3b 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -111,7 +111,7 @@ PRIVATE> : lcm ( a b -- c ) [ * ] 2keep gcd nip /i ; foldable -: divisor? ( x y -- ? ) +: divisor? ( m n -- ? ) mod 0 = ; : mod-inv ( x n -- y ) From 0dcb38d86a2826a488ec91e6455e9bee45a10339 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Fri, 3 Apr 2009 06:58:36 -0500 Subject: [PATCH 15/73] Some more GDI32 bindings --- basis/windows/gdi32/gdi32.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 549286d4f0..794aa0e32e 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1354,7 +1354,7 @@ FUNCTION: HRGN CreateRectRgn ( int x, int y, int w, int h ) ; ! FUNCTION: CreateRoundRectRgn ! FUNCTION: CreateScalableFontResourceA ! FUNCTION: CreateScalableFontResourceW -! FUNCTION: CreateSolidBrush +FUNCTION: HBRUSH CreateSolidBrush ( COLORREF colorref ) ; ! FUNCTION: DdEntry0 ! FUNCTION: DdEntry1 ! FUNCTION: DdEntry10 @@ -1501,6 +1501,7 @@ DESTRUCTOR: DeleteObject FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ; ALIAS: ExtTextOut ExtTextOutW ! FUNCTION: FillPath +FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ; ! FUNCTION: FillRgn ! FUNCTION: FixBrushOrgEx ! FUNCTION: FlattenPath @@ -1779,7 +1780,7 @@ ALIAS: GetTextMetrics GetTextMetricsW ! FUNCTION: PtVisible ! FUNCTION: QueryFontAssocStatus ! FUNCTION: RealizePalette -! FUNCTION: Rectangle +FUNCTION: BOOL Rectangle ( HDC hdc, int x, int y, int w, int h ) ; ! FUNCTION: RectInRegion ! FUNCTION: RectVisible ! FUNCTION: RemoveFontMemResourceEx From 7f4784151cd52d327eae32f665d0e6d8903e2f01 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Fri, 3 Apr 2009 06:59:27 -0500 Subject: [PATCH 16/73] Paint selection, and create bitmap with power of 2 size as an optimizaion --- basis/windows/uniscribe/uniscribe.factor | 165 +++++++++++++---------- 1 file changed, 94 insertions(+), 71 deletions(-) diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index cfd723ae8f..53d2d9918f 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -1,79 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs math sequences fry io.encodings.string -io.encodings.utf16n accessors arrays combinators destructors -cache namespaces init images.normalization alien.c-types locals +io.encodings.utf16n accessors arrays combinators destructors locals +cache namespaces init images.normalization fonts alien.c-types windows windows.usp10 windows.offscreen windows.gdi32 -windows.ole32 windows.types windows.fonts ; +windows.ole32 windows.types windows.fonts opengl.textures ; IN: windows.uniscribe -TUPLE: script-string metrics ssa size image string disposed ; - -: make-script-string ( dc string -- script-string ) - [ utf16n encode ] ! pString - [ length ] bi ! cString - dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size" - -1 ! iCharset -- Unicode - SSA_GLYPHS ! dwFlags - 0 ! iReqWidth - f ! psControl - f ! psState - f ! piDx - f ! pTabdef - f ! pbInClass - f ! pssa - [ ScriptStringAnalyse ] keep - [ ole32-error ] [ |ScriptStringFree *void* ] bi* ; - -: draw-script-string ( script-string -- ) - ! ssa - 0 ! iX - 0 ! iY - 0 ! uOptions - f ! prc - 0 ! iMinSel - 0 ! iMaxSel - FALSE ! fDisabled - ScriptStringOut ole32-error ; - -: set-dc-font ( dc font -- ) - [ cache-font SelectObject win32-error=0/f ] - [ background>> color>RGB SetBkColor drop ] - [ foreground>> color>RGB SetTextColor drop ] 2tri ; - -: script-string-size ( ssa -- dim ) - ScriptString_pSize - dup win32-error=0/f - [ SIZE-cx ] [ SIZE-cy ] bi 2array ; - -: dc-metrics ( dc -- metrics ) - "TEXTMETRICW" [ GetTextMetrics drop ] keep - TEXTMETRIC>metrics ; - -:: ( font string -- script-string ) - #! Comments annotate BOA constructor arguments - [| dc | - dc font set-dc-font - dc dc-metrics ! metrics - dc string make-script-string dup :> ssa ! ssa - dup script-string-size ! size - dup dc [ ssa draw-script-string ] make-bitmap-image - normalize-image ! image - string ! string - f script-string boa - ] with-memory-dc ; - -: text-position ( script-string -- loc ) drop { 0 0 } ; - -M: script-string dispose* ssa>> ScriptStringFree ole32-error ; - -SYMBOL: cached-script-strings - -: cached-script-string ( string font -- script-string ) - cached-script-strings get-global [ ] 2cache ; - -[ cached-script-strings set-global ] -"windows.uniscribe" add-init-hook +TUPLE: script-string font string metrics ssa size image disposed ; : line-offset>x ( n script-string -- x ) 2dup string>> length = [ @@ -92,4 +26,93 @@ SYMBOL: cached-script-strings swap ! iX 0 ! pCh 0 ! piTrailing - [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ; \ No newline at end of file + [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ; + +> ] when + [ utf16n encode ] ! pString + [ length ] bi ! cString + dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size" + -1 ! iCharset -- Unicode + SSA_GLYPHS ! dwFlags + 0 ! iReqWidth + f ! psControl + f ! psState + f ! piDx + f ! pTabdef + f ! pbInClass + f ! pssa + [ ScriptStringAnalyse ] keep + [ ole32-error ] [ |ScriptStringFree *void* ] bi* ; + +: set-dc-colors ( dc font -- ) + [ background>> color>RGB SetBkColor drop ] + [ foreground>> color>RGB SetTextColor drop ] 2bi ; + +: selection-start/end ( script-string -- iMinSel iMaxSel ) + string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ; + +: (draw-script-string) ( script-string -- ) + [ + ssa>> ! ssa + 0 ! iX + 0 ! iY + 0 ! uOptions + f ! prc + ] + [ selection-start/end ] bi + ! iMinSel + ! iMaxSel + FALSE ! fDisabled + ScriptStringOut ole32-error ; + +: draw-script-string ( dc script-string -- ) + [ font>> set-dc-colors ] keep (draw-script-string) ; + +: script-string-bitmap-size ( script-string -- dim ) + size>> dup small-texture? [ [ next-power-of-2 ] map ] when ; + +:: make-script-string-image ( dc script-string -- image ) + script-string script-string-bitmap-size dc + [ dc script-string draw-script-string ] make-bitmap-image ; + +: set-dc-font ( dc font -- ) + cache-font SelectObject win32-error=0/f ; + +: script-string-size ( script-string -- dim ) + ssa>> ScriptString_pSize + dup win32-error=0/f + [ SIZE-cx ] [ SIZE-cy ] bi 2array ; + +: dc-metrics ( dc -- metrics ) + "TEXTMETRICW" + [ GetTextMetrics drop ] keep + TEXTMETRIC>metrics ; + +: ( font string -- script-string ) + [ script-string new ] 2dip + [ >>font ] [ >>string ] bi* + [ + { + [ over font>> set-dc-font ] + [ dc-metrics >>metrics ] + [ over string>> make-script-string >>ssa ] + [ drop dup script-string-size >>size ] + [ over make-script-string-image >>image ] + } cleave + ] with-memory-dc ; + +PRIVATE> + +M: script-string dispose* + ssa>> ScriptStringFree ole32-error ; + +SYMBOL: cached-script-strings + +: cached-script-string ( string font -- script-string ) + cached-script-strings get-global [ ] 2cache ; + +[ cached-script-strings set-global ] +"windows.uniscribe" add-init-hook \ No newline at end of file From 1731b57249318eab39565b2f10bd31badaf446cc Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Fri, 3 Apr 2009 07:01:22 -0500 Subject: [PATCH 17/73] Add textures without alpha channels, cropping; update usages of ; don't ignore trailing in x>offset --- basis/images/images.factor | 6 ++- basis/opengl/textures/textures.factor | 60 ++++++++++++++---------- basis/ui/images/images.factor | 2 +- basis/ui/text/core-text/core-text.factor | 8 ++-- basis/ui/text/pango/pango.factor | 8 ++-- basis/ui/text/uniscribe/summary.txt | 2 +- basis/ui/text/uniscribe/uniscribe.factor | 9 ++-- 7 files changed, 56 insertions(+), 39 deletions(-) mode change 100644 => 100755 basis/images/images.factor mode change 100644 => 100755 basis/ui/images/images.factor diff --git a/basis/images/images.factor b/basis/images/images.factor old mode 100644 new mode 100755 index 08fbdd4e7e..b32953f67c --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -1,11 +1,13 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators kernel ; +USING: combinators kernel accessors ; IN: images SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ; +UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ; + : bytes-per-pixel ( component-order -- n ) { { L [ 1 ] } @@ -29,4 +31,6 @@ TUPLE: image dim component-order upside-down? bitmap ; : ( -- image ) image new ; inline +: has-alpha? ( image -- ? ) component-order>> alpha-channel? ; + GENERIC: load-image* ( path tuple -- image ) \ No newline at end of file diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 67094200d1..3efe924fb5 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -3,7 +3,7 @@ USING: accessors assocs cache colors.constants destructors fry kernel opengl opengl.gl combinators images images.tesselation grouping specialized-arrays.float locals sequences math math.vectors -math.matrices generalizations fry columns ; +math.matrices generalizations fry columns arrays ; IN: opengl.textures : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; @@ -25,7 +25,7 @@ GENERIC: draw-scaled-texture ( dim texture -- ) > [ 0 = ] all? [ + dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [ clone dup [ image-rows ] [ dim>> [ next-power-of-2 ] map ] @@ -93,26 +93,30 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ; : draw-textured-rect ( dim texture -- ) [ - (draw-textured-rect) - GL_TEXTURE_2D 0 glBindTexture + [ image>> has-alpha? [ GL_BLEND glDisable ] unless ] + [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ] + [ image>> has-alpha? [ GL_BLEND glEnable ] unless ] + tri ] with-texturing ; -: texture-coords ( dim -- coords ) - [ dup next-power-of-2 /f ] map - { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map +: texture-coords ( texture -- coords ) + [ + [ dim>> ] [ image>> dim>> ] bi v/ + { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } + [ v* ] with map + ] keep + image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when float-array{ } join ; : make-texture-display-list ( texture -- dlist ) GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ; -: ( image loc -- texture ) - single-texture new swap >>loc - swap - [ dim>> >>dim ] keep - [ dim>> product 0 = ] keep '[ - _ - [ dim>> texture-coords >>texture-coords ] - [ power-of-2-image make-texture >>texture ] bi +: ( image loc dim -- texture ) + [ power-of-2-image ] 2dip + single-texture new swap >>dim swap >>loc swap >>image + dup image>> dim>> product 0 = [ + dup texture-coords >>texture-coords + dup image>> make-texture >>texture dup make-texture-display-list >>display-list ] unless ; @@ -134,19 +138,20 @@ TUPLE: multi-texture grid display-list loc disposed ; : ( image-grid loc -- grid ) [ dup image-locs ] dip - '[ [ _ v+ |dispose ] 2map ] 2map ; + '[ [ _ v+ over dim>> |dispose ] 2map ] 2map ; : draw-textured-grid ( grid -- ) [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ; +: grid-has-alpha? ( grid -- ? ) + first first image>> has-alpha? ; + : make-textured-grid-display-list ( grid -- dlist ) GL_COMPILE [ [ - [ - [ - [ dim>> ] keep (draw-textured-rect) - ] each - ] each + [ grid-has-alpha? [ GL_BLEND glDisable ] unless ] + [ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ] + [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri GL_TEXTURE_2D 0 glBindTexture ] with-texturing ] make-dlist ; @@ -164,11 +169,14 @@ M: multi-texture draw-texture display-list>> [ glCallList ] when* ; M: multi-texture dispose* grid>> [ [ dispose ] each ] each ; -CONSTANT: max-texture-size { 256 256 } +CONSTANT: max-texture-size { 512 512 } PRIVATE> -: ( image loc -- texture ) - over dim>> max-texture-size [ <= ] 2all? +: small-texture? ( dim -- ? ) + max-texture-size [ <= ] 2all? ; + +: ( image loc dim -- texture ) + pick dim>> small-texture? [ ] - [ [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file + [ drop [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor old mode 100644 new mode 100755 index 2b1caa8ab9..8e36f2a3b1 --- a/basis/ui/images/images.factor +++ b/basis/ui/images/images.factor @@ -20,7 +20,7 @@ PRIVATE> : rendered-image ( path -- texture ) world get image-texture-cache - [ cached-image { 0 0 } ] cache ; + [ cached-image [ { 0 0 } ] keep dim>> ] cache ; : draw-image ( image-name -- ) rendered-image draw-texture ; diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor index 514d918e2f..404624da95 100755 --- a/basis/ui/text/core-text/core-text.factor +++ b/basis/ui/text/core-text/core-text.factor @@ -19,9 +19,11 @@ M: core-text-renderer flush-layout-cache cached-lines get purge-cache ; : rendered-line ( font string -- texture ) - world get world-text-handle - [ cached-line [ image>> ] [ loc>> ] bi ] - 2cache ; + world get world-text-handle [ + cached-line + [ image>> ] [ loc>> ] [ image>> dim>> ] tri + + ] 2cache ; M: core-text-renderer draw-string ( font string -- ) rendered-line draw-texture ; diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor index 3f4808a208..46328d11d5 100755 --- a/basis/ui/text/pango/pango.factor +++ b/basis/ui/text/pango/pango.factor @@ -15,9 +15,11 @@ M: pango-renderer flush-layout-cache cached-layouts get purge-cache ; : rendered-layout ( font string -- texture ) - world get world-text-handle - [ cached-layout [ image>> ] [ text-position vneg ] bi ] - 2cache ; + world get world-text-handle [ + cached-layout + [ image>> ] [ text-position vneg ] [ image>> dim>> ] tri + + ] 2cache ; M: pango-renderer draw-string ( font string -- ) rendered-layout draw-texture ; diff --git a/basis/ui/text/uniscribe/summary.txt b/basis/ui/text/uniscribe/summary.txt index 2480a4e98b..6fe24d9f74 100755 --- a/basis/ui/text/uniscribe/summary.txt +++ b/basis/ui/text/uniscribe/summary.txt @@ -1 +1 @@ -UI text rendering implementation using MS Windows Uniscribe library +UI text rendering implementation using the MS Windows Uniscribe library diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor index f7d4207927..dcec4ab17e 100755 --- a/basis/ui/text/uniscribe/uniscribe.factor +++ b/basis/ui/text/uniscribe/uniscribe.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs cache kernel math.vectors sequences +USING: accessors assocs cache kernel math math.vectors sequences fonts namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds windows.uniscribe ; IN: ui.text.uniscribe @@ -16,15 +16,16 @@ M: uniscribe-renderer flush-layout-cache : rendered-script-string ( font string -- texture ) world get world-text-handle - [ cached-script-string [ image>> ] [ text-position vneg ] bi ] + [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi ] 2cache ; M: uniscribe-renderer draw-string ( font string -- ) - [ drop ] [ rendered-script-string draw-texture ] if-empty ; + dup dup selection? [ string>> ] when empty? + [ 2drop ] [ rendered-script-string draw-texture ] if ; M: uniscribe-renderer x>offset ( x font string -- n ) [ 2drop 0 ] [ - cached-script-string x>line-offset drop + cached-script-string x>line-offset 0 = [ 1+ ] unless ] if-empty ; M: uniscribe-renderer offset>x ( n font string -- x ) From 1a35be8ae00360198c153dd23628dcc5504ca293 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 09:44:48 -0500 Subject: [PATCH 18/73] Add a new tip --- basis/help/tips/tips-docs.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/help/tips/tips-docs.factor b/basis/help/tips/tips-docs.factor index 48ed65b318..030c546f0c 100644 --- a/basis/help/tips/tips-docs.factor +++ b/basis/help/tips/tips-docs.factor @@ -1,6 +1,6 @@ IN: help.tips USING: help.markup help.syntax debugger prettyprint see help help.vocabs -help.apropos tools.time stack-checker editors ; +help.apropos tools.time stack-checker editors memory ; TIP: "To look at the most recent error, run " { $link :error } ". To look at the most recent error's callstack, run " { $link :c } "." ; @@ -20,7 +20,9 @@ TIP: "Power tools: " { $links see edit help about apropos time infer. } ; TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ; -TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $code "\"demos\" run" } ; +TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $snippet "\"demos\" run" } ; + +TIP: "To save time on reloading big libraries such as the " { $vocab-link "furnace" } " web framework, save the image after loading them using the " { $link save } " word." ; HELP: TIP: { $syntax "TIP: content ;" } From 73184698a88c6ff22ab817e890a25d61cbaf33d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 09:45:02 -0500 Subject: [PATCH 19/73] Remove unused entry from using list --- basis/pack/pack.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index 27cba6d6e7..3b9739fb0f 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays assocs byte-arrays io io.binary io.streams.string kernel math math.parser namespaces -make parser prettyprint quotations sequences strings vectors +make parser quotations sequences strings vectors words macros math.functions math.bitwise fry generalizations combinators.smart io.streams.byte-array io.encodings.binary math.vectors combinators multiline endian ; From 4f9ac11eedf2a5703fd5e8c0c1fffd49769583e0 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Fri, 3 Apr 2009 09:48:10 -0500 Subject: [PATCH 20/73] Remove unused dependency --- basis/windows/windows.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 basis/windows/windows.factor diff --git a/basis/windows/windows.factor b/basis/windows/windows.factor old mode 100644 new mode 100755 index 44db355c99..902b1bec8d --- a/basis/windows/windows.factor +++ b/basis/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax alien.c-types alien.strings arrays -combinators kernel math namespaces parser prettyprint sequences +combinators kernel math namespaces parser sequences windows.errors windows.types windows.kernel32 words io.encodings.utf16n ; IN: windows From 82317980a483948f87c52005295999c410118c07 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Fri, 3 Apr 2009 09:48:16 -0500 Subject: [PATCH 21/73] Don't strip out superclass word prop since UI needs it --- basis/tools/deploy/shaker/shaker.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 8ee0393091..7fe2db96a0 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -157,7 +157,8 @@ IN: tools.deploy.shaker "specializer" "step-into" "step-into?" - "superclass" + ! UI needs this + ! "superclass" "transform-n" "transform-quot" "tuple-dispatch-generic" From 5a6bcbb2317375b983eb739bb440738bb269d94a Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Fri, 3 Apr 2009 09:48:45 -0500 Subject: [PATCH 22/73] Add empty file so that old builder continues to work --- build-support/dlls.txt | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 build-support/dlls.txt diff --git a/build-support/dlls.txt b/build-support/dlls.txt new file mode 100644 index 0000000000..e69de29bb2 From 9907bd9fe26609a77654e4ae5f5a0c2c58c6fc2d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 10:16:25 -0500 Subject: [PATCH 23/73] Add fseek primitive so that c-streams can seek. This lets the UI work without native IO --- .../known-words/known-words.factor | 2 ++ core/bootstrap/primitives.factor | 1 + core/io/streams/c/c.factor | 26 ++++++++++++------- vm/io.c | 25 ++++++++++++++++++ vm/io.h | 1 + vm/primitives.c | 1 + 6 files changed, 47 insertions(+), 9 deletions(-) diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index a38bb42c7e..c55e69a8a2 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -605,6 +605,8 @@ M: object infer-call* \ fflush { alien } { } define-primitive +\ fseek { alien integer integer } { } define-primitive + \ fclose { alien } { } define-primitive \ { object } { wrapper } define-primitive diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index e3803f2150..4466bd9bfe 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -510,6 +510,7 @@ tuple { "fputc" "io.streams.c" (( ch alien -- )) } { "fwrite" "io.streams.c" (( string alien -- )) } { "fflush" "io.streams.c" (( alien -- )) } + { "fseek" "io.streams.c" (( alien offset whence -- )) } { "fclose" "io.streams.c" (( alien -- )) } { "" "kernel" (( obj -- wrapper )) } { "(clone)" "kernel" (( obj -- newobj )) } diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index eb23a627b9..bec3bdc6bf 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,11 +1,24 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private namespaces make io io.encodings sequences math generic threads.private classes io.backend -io.files continuations destructors byte-arrays accessors ; +io.files continuations destructors byte-arrays accessors +combinators ; IN: io.streams.c -TUPLE: c-writer handle disposed ; +TUPLE: c-stream handle disposed ; + +M: c-stream dispose* handle>> fclose ; + +M: c-stream stream-seek + handle>> swap { + { seek-absolute [ 0 ] } + { seek-relative [ 1 ] } + { seek-end [ 2 ] } + [ bad-seek-type ] + } case fseek ; + +TUPLE: c-writer < c-stream ; : ( handle -- stream ) f c-writer boa ; @@ -17,9 +30,7 @@ M: c-writer stream-write dup check-disposed handle>> fwrite ; M: c-writer stream-flush dup check-disposed handle>> fflush ; -M: c-writer dispose* handle>> fclose ; - -TUPLE: c-reader handle disposed ; +TUPLE: c-reader < c-stream ; : ( handle -- stream ) f c-reader boa ; @@ -43,9 +54,6 @@ M: c-reader stream-read-until [ swap read-until-loop ] B{ } make swap over empty? over not and [ 2drop f f ] when ; -M: c-reader dispose* - handle>> fclose ; - M: c-io-backend init-io ; : stdin-handle ( -- alien ) 11 getenv ; diff --git a/vm/io.c b/vm/io.c index bad4854775..950b1ed080 100755 --- a/vm/io.c +++ b/vm/io.c @@ -163,6 +163,31 @@ void primitive_fwrite(void) } } +void primitive_fseek(void) +{ + int whence = to_fixnum(dpop()); + FILE *file = unbox_alien(); + off_t offset = to_signed_8(dpop()); + + switch(whence) + { + case 0: whence = SEEK_SET; break; + case 1: whence = SEEK_CUR; break; + case 2: whence = SEEK_END; break; + default: + critical_error("Bad value for whence",whence); + break; + } + + if(fseeko(file,offset,whence) == -1) + { + io_error(); + + /* Still here? EINTR */ + critical_error("Don't know what to do; EINTR from fseek()?",0); + } +} + void primitive_fflush(void) { FILE *file = unbox_alien(); diff --git a/vm/io.h b/vm/io.h index dc7d69edee..63a9c35490 100755 --- a/vm/io.h +++ b/vm/io.h @@ -9,6 +9,7 @@ void primitive_fread(void); void primitive_fputc(void); void primitive_fwrite(void); void primitive_fflush(void); +void primitive_fseek(void); void primitive_fclose(void); /* Platform specific primitives */ diff --git a/vm/primitives.c b/vm/primitives.c index 00103ac047..80b672d9d2 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -121,6 +121,7 @@ void *primitives[] = { primitive_fputc, primitive_fwrite, primitive_fflush, + primitive_fseek, primitive_fclose, primitive_wrapper, primitive_clone, From f42c23de9d150daebefc833087708b2f79c5d2d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 10:16:40 -0500 Subject: [PATCH 24/73] Copy UI theme over to deployed binaries --- basis/tools/deploy/macosx/macosx.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor index 11e2b8957b..f753e38fb2 100755 --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -42,11 +42,12 @@ IN: tools.deploy.macosx : create-app-dir ( vocab bundle-name -- vm ) [ - nip - [ copy-dll ] - [ copy-nib ] - [ "Contents/Resources" append-path make-directories ] - tri + nip { + [ copy-dll ] + [ copy-nib ] + [ "Contents/Resources" append-path make-directories ] + [ "Contents/Resources" copy-theme ] + } cleave ] [ create-app-plist ] [ "Contents/MacOS/" append-path copy-vm ] 2tri From 535850f3ea5d31f44bd9d08fa9ac1700a15b48b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 10:16:56 -0500 Subject: [PATCH 25/73] Fix vocab: and word name stripping in deployed binaries --- basis/tools/deploy/shaker/shaker.factor | 1 - vm/factor.c | 7 ++++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 8ee0393091..0284891ebe 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -276,7 +276,6 @@ IN: tools.deploy.shaker lexer-factory print-use-hook root-cache - vocab-roots vocabs:dictionary vocabs:load-vocab-hook word diff --git a/vm/factor.c b/vm/factor.c index d9042c9455..9b5d3de602 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -132,9 +132,7 @@ void init_factor(F_PARAMETERS *p) userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING)); userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING)); userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL)); - userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces); - userenv[EXECUTABLE_ENV] = (p->executable_path ? - tag_object(from_native_string(p->executable_path)) : F); + userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F); userenv[ARGS_ENV] = F; userenv[EMBEDDED_ENV] = F; @@ -142,7 +140,10 @@ void init_factor(F_PARAMETERS *p) gc_off = false; if(!stage2) + { + userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces); do_stage1_init(); + } } /* May allocate memory */ From f7ba7b4bfa6801073029f0579b7222d422078afa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 10:20:42 -0500 Subject: [PATCH 26/73] Fix deploy descriptor for color picker --- extra/color-picker/deploy.factor | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/extra/color-picker/deploy.factor b/extra/color-picker/deploy.factor index fcb4dbd69d..eeeb63dd7d 100755 --- a/extra/color-picker/deploy.factor +++ b/extra/color-picker/deploy.factor @@ -1,12 +1,15 @@ USING: tools.deploy.config ; -V{ - { deploy-ui? t } - { deploy-io 1 } - { deploy-reflection 1 } - { deploy-compiler? t } - { deploy-math? t } - { deploy-word-props? f } - { deploy-c-types? f } - { "stop-after-last-window?" t } +H{ { deploy-name "Color Picker" } + { deploy-word-props? f } + { deploy-ui? t } + { deploy-threads? t } + { deploy-unicode? f } + { deploy-c-types? f } + { deploy-word-defs? f } + { deploy-compiler? t } + { deploy-io 2 } + { deploy-reflection 1 } + { "stop-after-last-window?" t } + { deploy-math? t } } From 34c8e07900277a88659d600e036ebfbad8e210e2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 10:35:43 -0500 Subject: [PATCH 27/73] make FSEEK macro for using _fseeki64 instead of fseeko on windows --- vm/io.c | 2 +- vm/os-genunix.h | 1 + vm/os-windows.h | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/vm/io.c b/vm/io.c index 950b1ed080..d88f1bab50 100755 --- a/vm/io.c +++ b/vm/io.c @@ -179,7 +179,7 @@ void primitive_fseek(void) break; } - if(fseeko(file,offset,whence) == -1) + if(FSEEK(file,offset,whence) == -1) { io_error(); diff --git a/vm/os-genunix.h b/vm/os-genunix.h index 7afc68998d..9a00758c8a 100644 --- a/vm/os-genunix.h +++ b/vm/os-genunix.h @@ -1,5 +1,6 @@ #define DLLEXPORT #define NULL_DLL NULL +#define FSEEK fseeko void c_to_factor_toplevel(CELL quot); void init_signals(void); diff --git a/vm/os-windows.h b/vm/os-windows.h index 0704459dd0..f47ca951ee 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -20,6 +20,7 @@ typedef wchar_t F_CHAR; #define STRNCMP wcsncmp #define STRDUP _wcsdup #define MIN(a,b) ((a)>(b)?(b):(a)) +#define FSEEK _fseeki64 #ifdef WIN64 #define CELL_FORMAT "%Iu" From 4f3e8be3f6a3ad28e602fcd9ebf152abf80a2f05 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 12:26:04 -0500 Subject: [PATCH 28/73] move FSEEK definition from os-genuinx.h to os-unix.h --- vm/os-genunix.h | 1 - vm/os-unix.h | 2 ++ 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/vm/os-genunix.h b/vm/os-genunix.h index 9a00758c8a..7afc68998d 100644 --- a/vm/os-genunix.h +++ b/vm/os-genunix.h @@ -1,6 +1,5 @@ #define DLLEXPORT #define NULL_DLL NULL -#define FSEEK fseeko void c_to_factor_toplevel(CELL quot); void init_signals(void); diff --git a/vm/os-unix.h b/vm/os-unix.h index d2f34b4bc4..35abfee41c 100755 --- a/vm/os-unix.h +++ b/vm/os-unix.h @@ -23,6 +23,8 @@ typedef char F_SYMBOL; #define STRNCMP strncmp #define STRDUP strdup +#define FSEEK fseeko + #define FIXNUM_FORMAT "%ld" #define CELL_FORMAT "%lu" #define CELL_HEX_FORMAT "%lx" From a42b872a23859635459e11522d11b20217df0997 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 12:40:45 -0500 Subject: [PATCH 29/73] fix bug in take-sequence --- extra/html/parser/state/state-tests.factor | 3 +++ extra/html/parser/state/state.factor | 11 +++++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor index 75db1a373e..c8a8a95892 100644 --- a/extra/html/parser/state/state-tests.factor +++ b/extra/html/parser/state/state-tests.factor @@ -99,3 +99,6 @@ IN: html.parser.state.tests [ "" ] [ "abc" dup "abc" take-sequence drop take-rest ] unit-test + +[ f ] +[ "abc" "abcdefg" take-sequence ] unit-test diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor index 5f845ce810..2bcd08be5f 100644 --- a/extra/html/parser/state/state.factor +++ b/extra/html/parser/state/state.factor @@ -51,9 +51,16 @@ TUPLE: state-parser sequence n ; : take-while ( state-parser quot: ( obj -- ? ) -- sequence/f ) [ not ] compose take-until ; inline +: ( from to seq -- slice/f ) + 3dup { + [ 2drop 0 < ] + [ [ drop ] 2dip length > ] + [ drop > ] + } 3|| [ 3drop f ] [ slice boa ] if ; inline + :: take-sequence ( state-parser sequence -- obj/f ) - state-parser [ n>> dup sequence length + ] [ sequence>> ] bi - sequence sequence= [ + state-parser [ n>> dup sequence length + ] [ sequence>> ] bi + sequence sequence= [ sequence state-parser [ sequence length + ] change-n drop ] [ From c780457ddb8c74e1d5289313da6fe9aaffb518cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 12:54:34 -0500 Subject: [PATCH 30/73] Fix up ui.offscreen --- extra/ui/offscreen/offscreen-docs.factor | 10 +++++----- extra/ui/offscreen/offscreen.factor | 18 ++++++++++++------ 2 files changed, 17 insertions(+), 11 deletions(-) diff --git a/extra/ui/offscreen/offscreen-docs.factor b/extra/ui/offscreen/offscreen-docs.factor index 4123a83675..b9d68ffaeb 100644 --- a/extra/ui/offscreen/offscreen-docs.factor +++ b/extra/ui/offscreen/offscreen-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations ui.gadgets -images.bitmap strings ui.gadgets.worlds ; +images strings ui.gadgets.worlds ; IN: ui.offscreen HELP: @@ -26,9 +26,9 @@ HELP: do-offscreen HELP: gadget>bitmap { $values { "gadget" gadget } - { "bitmap" bitmap } + { "image" image } } -{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates a " { $link bitmap } " from its contents." } ; +{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ; HELP: offscreen-world { $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ; @@ -36,9 +36,9 @@ HELP: offscreen-world HELP: offscreen-world>bitmap { $values { "world" offscreen-world } - { "bitmap" bitmap } + { "image" image } } -{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link bitmap } " object." } ; +{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ; HELP: open-offscreen { $values diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index f0b81ccacd..8d197eb844 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,7 +1,7 @@ ! (c) 2008 Joe Groff, see license for details -USING: accessors continuations images.bitmap kernel math +USING: accessors alien.c-types continuations images kernel math sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds -ui.private ui ui.backend destructors ; +ui.private ui ui.backend destructors locals ; IN: ui.offscreen TUPLE: offscreen-world < world ; @@ -19,18 +19,24 @@ M: offscreen-world ungraft* : open-offscreen ( gadget -- world ) "" f - [ open-world-window dup relayout-1 ] keep + [ open-world-window ] [ relayout-1 ] [ ] tri notify-queued ; : close-offscreen ( world -- ) ungraft notify-queued ; -: offscreen-world>bitmap ( world -- bitmap ) - offscreen-pixels bgra>bitmap ; +:: bgrx>bitmap ( alien w h -- image ) + + { w h } >>dim + alien w h * 4 * memory>byte-array >>bitmap + BGRX >>component-order ; + +: offscreen-world>bitmap ( world -- image ) + offscreen-pixels bgrx>bitmap ; : do-offscreen ( gadget quot: ( offscreen-world -- ) -- ) [ open-offscreen ] dip over [ slip ] [ close-offscreen ] [ ] cleanup ; inline -: gadget>bitmap ( gadget -- bitmap ) +: gadget>bitmap ( gadget -- image ) [ offscreen-world>bitmap ] do-offscreen ; From 2ff6c7ed072bd090ea7b51a0d6af9cf80f90c80f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 14:59:46 -0500 Subject: [PATCH 31/73] use fseek on windows instead of _fseeki64 --- vm/os-windows.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-windows.h b/vm/os-windows.h index f47ca951ee..36d350f50d 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -20,7 +20,7 @@ typedef wchar_t F_CHAR; #define STRNCMP wcsncmp #define STRDUP _wcsdup #define MIN(a,b) ((a)>(b)?(b):(a)) -#define FSEEK _fseeki64 +#define FSEEK fseek #ifdef WIN64 #define CELL_FORMAT "%Iu" From 775ca0a95647db832105fa163166e45d34076a7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 16:30:59 -0500 Subject: [PATCH 32/73] mason: run factor.com on windows --- extra/mason/child/child-tests.factor | 8 ++++++++ extra/mason/child/child.factor | 7 +++++-- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 104360e1fa..27bb42ed07 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -32,3 +32,11 @@ USING: mason.child mason.config tools.test namespaces ; boot-cmd ] with-scope ] unit-test + +[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [ + [ + "winnt" target-os set + "x86.32" target-cpu set + boot-cmd + ] with-scope +] unit-test diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index 2ed9226524..feb11933fb 100755 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -25,8 +25,11 @@ IN: mason.child builds-factor-image "." copy-file-into builds-factor-image "factor" copy-file-into ; +: factor-vm ( -- string ) + target-os get "winnt" = "./factor.com" "./factor" ? ; + : boot-cmd ( -- cmd ) - "./factor" + factor-vm "-i=" boot-image-name append "-no-user-init" 3array ; @@ -42,7 +45,7 @@ IN: mason.child try-process ] with-directory ; -: test-cmd ( -- cmd ) { "./factor" "-run=mason.test" } ; +: test-cmd ( -- cmd ) factor-vm "-run=mason.test" 2array ; : test ( -- ) "factor" [ From 32954b75ad46980d4a0f1e90c683bc2242de9fd3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 17:28:31 -0500 Subject: [PATCH 33/73] use functors to define human-sort --- basis/sorting/human/human-docs.factor | 2 +- basis/sorting/human/human.factor | 17 ++--------------- 2 files changed, 3 insertions(+), 16 deletions(-) diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor index 5952b3e3f9..606eef670a 100644 --- a/basis/sorting/human/human-docs.factor +++ b/basis/sorting/human/human-docs.factor @@ -35,7 +35,7 @@ HELP: human-compare HELP: human-sort { $values { "seq" sequence } - { "seq'" sequence } + { "sortedseq" sequence } } { $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ; diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index c07ed8758b..b3dae45a9b 100644 --- a/basis/sorting/human/human.factor +++ b/basis/sorting/human/human.factor @@ -1,22 +1,9 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: peg.ebnf math.parser kernel assocs sorting fry -math.order sequences ascii splitting.monotonic ; +USING: math.parser peg.ebnf sorting.functor ; IN: sorting.human : find-numbers ( string -- seq ) [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ; -: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ; - -: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline - -: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline - -: human-sort ( seq -- seq' ) [ human<=> ] sort ; - -: human-sort-keys ( seq -- sortedseq ) - [ [ first ] human-compare ] sort ; - -: human-sort-values ( seq -- sortedseq ) - [ [ second ] human-compare ] sort ; +<< "human" [ find-numbers ] define-sorting >> From ce73c17c1d350a2743b1b3a96fea255aa9535c3b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 17:28:55 -0500 Subject: [PATCH 34/73] add sorting.functor --- basis/sorting/functor/authors.txt | 1 + basis/sorting/functor/functor.factor | 24 ++++++++++++++++++++++++ 2 files changed, 25 insertions(+) create mode 100644 basis/sorting/functor/authors.txt create mode 100644 basis/sorting/functor/functor.factor diff --git a/basis/sorting/functor/authors.txt b/basis/sorting/functor/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/sorting/functor/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor new file mode 100644 index 0000000000..022ef3fb0d --- /dev/null +++ b/basis/sorting/functor/functor.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: functors kernel math.order sequences sorting ; +IN: sorting.functor + +FUNCTOR: define-sorting ( NAME QUOT -- ) + +NAME<=> DEFINES ${NAME}<=> +NAME>=< DEFINES ${NAME}>=< +NAME-compare DEFINES ${NAME}-compare +NAME-sort DEFINES ${NAME}-sort +NAME-sort-keys DEFINES ${NAME}-sort-keys +NAME-sort-values DEFINES ${NAME}-sort-values + +WHERE + +: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ; +: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ; +: NAME-compare ( obj1 obj2 quot -- <=> ) bi@ NAME<=> ; inline +: NAME-sort ( seq -- sortedseq ) [ NAME<=> ] sort ; +: NAME-sort-keys ( seq -- sortedseq ) [ [ first ] NAME-compare ] sort ; +: NAME-sort-values ( seq -- sortedseq ) [ [ second ] NAME-compare ] sort ; + +;FUNCTOR From 2e1652db6d5d9927e64e4d844b6a0efb04e73ad7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 17:38:21 -0500 Subject: [PATCH 35/73] simplify sorting.slots a bit --- basis/sorting/slots/slots.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 56b6a115f0..bce9442e44 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -20,7 +20,7 @@ PRIVATE> MACRO: compare-slots ( sort-specs -- <=> ) #! sort-spec: { accessors comparator } - [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; + '[ _ [ slot-comparator ] map 2|| +eq+ or ] ; : sort-by-slots ( seq sort-specs -- seq' ) '[ _ compare-slots ] sort ; From 73a2fa49c53ad715bcfc625f164db36cf4fac742 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 18:19:45 -0500 Subject: [PATCH 36/73] add title sort for use with joe's mp3 player --- basis/sorting/title/authors.txt | 1 + basis/sorting/title/title-tests.factor | 40 ++++++++++++++++++++++++++ basis/sorting/title/title.factor | 7 +++++ 3 files changed, 48 insertions(+) create mode 100644 basis/sorting/title/authors.txt create mode 100644 basis/sorting/title/title-tests.factor create mode 100644 basis/sorting/title/title.factor diff --git a/basis/sorting/title/authors.txt b/basis/sorting/title/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/sorting/title/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/sorting/title/title-tests.factor b/basis/sorting/title/title-tests.factor new file mode 100644 index 0000000000..34d9e90b38 --- /dev/null +++ b/basis/sorting/title/title-tests.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test sorting.title ; +IN: sorting.title.tests + +: sort-me ( -- seq ) + { + "The Beatles" + "A river runs through it" + "Another" + "la vida loca" + "Basketball" + "racquetball" + "Los Fujis" + "los Fujis" + "La cucaracha" + "a day to remember" + "of mice and men" + "on belay" + "for the horde" + } ; +[ + { + "Another" + "Basketball" + "The Beatles" + "La cucaracha" + "a day to remember" + "for the horde" + "Los Fujis" + "los Fujis" + "of mice and men" + "on belay" + "racquetball" + "A river runs through it" + "la vida loca" + } +] [ + sort-me title-sort +] unit-test diff --git a/basis/sorting/title/title.factor b/basis/sorting/title/title.factor new file mode 100644 index 0000000000..dbdbf8a8fb --- /dev/null +++ b/basis/sorting/title/title.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: sorting.functor regexp kernel accessors sequences +unicode.case ; +IN: sorting.title + +<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >> From 3137d12f12e3823a46a5350dad2c52639dbbdab3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 19:30:07 -0500 Subject: [PATCH 37/73] Fix some minor UI bugs --- .../gadgets/line-support/line-support.factor | 3 +++ basis/ui/gadgets/scrollers/scrollers.factor | 1 + basis/ui/gadgets/tables/tables.factor | 25 ++++++++----------- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/basis/ui/gadgets/line-support/line-support.factor b/basis/ui/gadgets/line-support/line-support.factor index 80feb31ad2..b9fe10c530 100644 --- a/basis/ui/gadgets/line-support/line-support.factor +++ b/basis/ui/gadgets/line-support/line-support.factor @@ -30,6 +30,9 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ; : validate-line ( m gadget -- n ) control-value [ drop f ] [ length 1- min 0 max ] if-empty ; +: valid-line? ( n gadget -- ? ) + control-value length 1- 0 swap between? ; + : visible-line ( gadget quot -- n ) '[ [ clip get @ origin get [ second ] bi@ - ] dip diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index 64e035c81b..b80940bd4a 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -58,6 +58,7 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ; { [ scroller-value vneg offset-rect ] [ viewport>> dim>> rect-min ] + [ viewport>> loc>> offset-rect ] [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ] [ scroller-value v+ ] [ scroll ] diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index f2ed5b10e0..312cb59efd 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -261,19 +261,20 @@ M: table model-changed row-rect [ { 0 1 } v* ] change-dim ; : (select-row) ( table n -- ) - [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ] + [ dup [ [ thin-row-rect dup unparse show ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ] [ >>selected-index relayout-1 ] 2bi ; : mouse-row ( table -- n ) [ hand-rel second ] keep y>line ; +: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- ) + [ [ mouse-row ] keep 2dup valid-line? ] + [ ] [ '[ nip @ ] ] tri* if ; inline + : table-button-down ( table -- ) dup takes-focus?>> [ dup request-focus ] when - dup control-value empty? [ drop ] [ - dup [ mouse-row ] keep validate-line - [ >>mouse-index ] [ (select-row) ] bi - ] if ; + [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ; PRIVATE> @@ -283,11 +284,14 @@ PRIVATE> [ 2drop ] if ; +: row-action? ( table -- ? ) + [ [ mouse-row ] keep valid-line? ] + [ single-click?>> hand-click# get 2 = or ] bi and ; + > hand-click# get 2 = or - [ row-action ] [ update-selected-value ] if ; + dup row-action? [ row-action ] [ update-selected-value ] if ; : select-row ( table n -- ) over validate-line @@ -320,13 +324,6 @@ PRIVATE> : next-page ( table -- ) 1 prev/next-page ; -: valid-row? ( row table -- ? ) - control-value length 1- 0 swap between? ; - -: if-mouse-row ( table true false -- ) - [ [ mouse-row ] keep 2dup valid-row? ] - [ ] [ '[ nip @ ] ] tri* if ; inline - : show-mouse-help ( table -- ) [ swap From 695b97e6e6a593839b5f5f4f7b723de6ca815867 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 19:35:22 -0500 Subject: [PATCH 38/73] Remove debug stuff --- basis/ui/gadgets/tables/tables.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 312cb59efd..77249149ae 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -261,7 +261,7 @@ M: table model-changed row-rect [ { 0 1 } v* ] change-dim ; : (select-row) ( table n -- ) - [ dup [ [ thin-row-rect dup unparse show ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ] + [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ] [ >>selected-index relayout-1 ] 2bi ; From 8fdb3bb27aeb1969315585630d8d6c5c9caeba89 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 19:43:10 -0500 Subject: [PATCH 39/73] define a sort-by to take a sequence of comparators without slots --- basis/sorting/slots/slots-tests.factor | 18 +++++++++++++++++- basis/sorting/slots/slots.factor | 14 ++++++++++++-- 2 files changed, 29 insertions(+), 3 deletions(-) diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index 46824c6fdb..83900461c3 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math.order sorting.slots tools.test -sorting.human arrays sequences kernel assocs multiline ; +sorting.human arrays sequences kernel assocs multiline +sorting.functor ; IN: sorting.literals.tests TUPLE: sort-test a b c tuple2 ; @@ -76,6 +77,9 @@ TUPLE: tuple2 d ; [ { } ] [ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test +[ { } ] +[ { } { } sort-by-slots ] unit-test + [ { T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } } @@ -143,3 +147,15 @@ TUPLE: tuple2 d ; T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } } } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map ] unit-test + + +[ { "a" "b" "c" } ] [ { "b" "c" "a" } { <=> <=> } sort-by ] unit-test +[ { "b" "c" "a" } ] [ { "b" "c" "a" } { } sort-by ] unit-test + +<< "length-test" [ length ] define-sorting >> + +[ { { 1 } { 1 2 3 } { 1 3 2 } { 3 2 1 } } ] +[ + { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } } + { length-test<=> <=> } sort-by +] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index bce9442e44..4b6743af5c 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -7,6 +7,9 @@ IN: sorting.slots MACRO: compare-slots ( sort-specs -- <=> ) #! sort-spec: { accessors comparator } - '[ _ [ slot-comparator ] map 2|| +eq+ or ] ; + [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; -: sort-by-slots ( seq sort-specs -- seq' ) +: sort-by-slots ( seq sort-specs -- sortedseq ) '[ _ compare-slots ] sort ; +MACRO: compare-seq ( seq -- quot ) + [ short-circuit-comparator ] map '[ _ 2|| +eq+ or ] ; + +: sort-by ( seq sort-seq -- sortedseq ) + '[ _ compare-seq ] sort ; + + MACRO: split-by-slots ( accessor-seqs -- quot ) [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map '[ [ _ 2&& ] slice monotonic-slice ] ; From c97ca399d8ea5434b332c30ba1d25ab04d14c109 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 19:49:49 -0500 Subject: [PATCH 40/73] refactor a bit, document sort-by --- basis/sorting/slots/slots-docs.factor | 15 ++++++++++++--- basis/sorting/slots/slots.factor | 7 +++---- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index a3bdbf9ac1..cc89d497e7 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -14,7 +14,7 @@ HELP: compare-slots HELP: sort-by-slots { $values { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" } - { "seq'" sequence } + { "sortedseq" sequence } } { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." } { $examples @@ -39,11 +39,20 @@ HELP: split-by-slots } { $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ; +HELP: sort-by +{ $values + { "seq" sequence } { "sort-seq" "a sequence of comparators" } + { "sortedseq" sequence } +} +{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ; + ARTICLE: "sorting.slots" "Sorting by slots" "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl "Comparing two objects by a sequence of slots:" { $subsection compare-slots } -"Sorting a sequence by a sequence of slots:" -{ $subsection sort-by-slots } ; +"Sorting a sequence of tuples by a slot/comparator pairs:" +{ $subsection sort-by-slots } +"Sorting a sequence by a sequence of comparators:" +{ $subsection sort-by } ; ABOUT: "sorting.slots" diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 4b6743af5c..2dccc60821 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -8,7 +8,7 @@ IN: sorting.slots @@ -29,12 +29,11 @@ MACRO: compare-slots ( sort-specs -- <=> ) '[ _ compare-slots ] sort ; MACRO: compare-seq ( seq -- quot ) - [ short-circuit-comparator ] map '[ _ 2|| +eq+ or ] ; + [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; : sort-by ( seq sort-seq -- sortedseq ) '[ _ compare-seq ] sort ; - MACRO: split-by-slots ( accessor-seqs -- quot ) [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map '[ [ _ 2&& ] slice monotonic-slice ] ; From bae79235946230bab13e48dadd7890a6defcf633 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 19:50:46 -0500 Subject: [PATCH 41/73] Fix more cosmetic issues --- basis/ui/gadgets/editors/editors.factor | 2 +- basis/ui/gadgets/scrollers/scrollers.factor | 1 - basis/ui/tools/listener/completion/completion.factor | 1 + 3 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index f5b7f63d22..3eb40a5135 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -141,7 +141,7 @@ M: editor ungraft* : scroll>caret ( editor -- ) dup graft-state>> second [ [ - [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi + [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi ] keep scroll>rect ] [ drop ] if ; diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index b80940bd4a..a526cc618b 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -54,7 +54,6 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ; 2dup control-value = [ 2drop ] [ set-control-value ] if ; : (scroll>rect) ( rect scroller -- ) - [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi ] dip { [ scroller-value vneg offset-rect ] [ viewport>> dim>> rect-min ] diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 022a2daabf..ba66121bc2 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -141,6 +141,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- ) t >>selection-required? t >>single-click? 30 >>min-cols + 10 >>min-rows 10 >>max-rows dup '[ _ accept-completion ] >>action ; From 4c7b2f93379cf5925550747780f10d654d4577c2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 20:05:19 -0500 Subject: [PATCH 42/73] fix deriving urls in spider --- extra/spider/spider.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index aeb4676767..5398e32ff4 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -84,7 +84,7 @@ TUPLE: unique-deque assoc deque ; : normalize-hrefs ( links spider -- links' ) currently-spidering>> present swap - [ dup url-absolute? [ derive-url ] [ url-append-path >url ] if ] with map ; + [ [ >url ] bi@ derive-url ] with map ; : print-spidering ( url depth -- ) "depth: " write number>string write From 8875c2ba26c8adeaf72e9bfeb6f58d40f59a3dde Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 21:15:52 -0500 Subject: [PATCH 43/73] return links as URL objects in html vocab --- extra/html/parser/analyzer/analyzer.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 54b8c8fc69..2196f1baaa 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -127,11 +127,13 @@ TUPLE: link attributes clickable ; [ name>> "a" = ] [ attributes>> "href" swap key? ] bi and ] filter ] map sift - [ [ attributes>> "href" swap at ] map ] map concat ; + [ [ attributes>> "href" swap at ] map ] map concat + [ >url ] map ; : find-frame-links ( vector -- vector' ) [ name>> "frame" = ] find-between-all - [ [ attributes>> "src" swap at ] map sift ] map concat sift ; + [ [ attributes>> "src" swap at ] map sift ] map concat sift + [ >url ] map ; : find-all-links ( vector -- vector' ) [ find-hrefs ] [ find-frame-links ] bi append prune ; From 1ee52e2090aa1cf2aa223fbcf849b97bee4d0868 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 3 Apr 2009 21:16:08 -0500 Subject: [PATCH 44/73] refactoring spider --- extra/spider/spider.factor | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 5398e32ff4..07989860ff 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -4,15 +4,15 @@ USING: accessors fry html.parser html.parser.analyzer http.client kernel tools.time sets assocs sequences concurrency.combinators io threads namespaces math multiline math.parser inspector urls logging combinators.short-circuit -continuations calendar prettyprint dlists deques locals -present ; +continuations calendar prettyprint dlists deques locals ; IN: spider TUPLE: spider base count max-count sleep max-depth initial-links -filters spidered todo nonmatching quiet currently-spidering ; +filters spidered todo nonmatching quiet currently-spidering +#threads follow-robots ; -TUPLE: spider-result url depth headers fetch-time parsed-html -links processing-time timestamp ; +TUPLE: spider-result url depth headers +fetched-in parsed-html links processed-in fetched-at ; TUPLE: todo-url url depth ; @@ -51,7 +51,8 @@ TUPLE: unique-deque assoc deque ; 0 >>max-depth 0 >>count 1/0. >>max-count - H{ } clone >>spidered ; + H{ } clone >>spidered + 1 >>#threads ; > present swap - [ [ >url ] bi@ derive-url ] with map ; +: normalize-hrefs ( base links -- links' ) + [ derive-url ] with map ; : print-spidering ( url depth -- ) "depth: " write number>string write @@ -94,7 +91,9 @@ TUPLE: unique-deque assoc deque ; f url spider spidered>> set-at [ url http-get ] benchmark :> fetch-time :> html :> headers [ - html parse-html [ ] [ find-all-links spider normalize-hrefs ] bi + html parse-html + spider currently-spidering>> + over find-all-links normalize-hrefs ] benchmark :> processing-time :> links :> parsed-html url depth headers fetch-time parsed-html links processing-time now spider-result boa ; @@ -107,11 +106,12 @@ TUPLE: unique-deque assoc deque ; \ spider-page ERROR add-error-logging -: spider-sleep ( spider -- ) - sleep>> [ sleep ] when* ; +: spider-sleep ( spider -- ) sleep>> [ sleep ] when* ; -:: queue-initial-links ( spider -- spider ) - spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ; +: queue-initial-links ( spider -- ) + [ + [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0 + ] keep add-todo ; : spider-page? ( spider -- ? ) { @@ -121,7 +121,7 @@ TUPLE: unique-deque assoc deque ; } 1&& ; : setup-next-url ( spider -- spider url depth ) - dup todo>> peek-url url>> present >>currently-spidering + dup todo>> peek-url url>> >>currently-spidering dup todo>> pop-url [ url>> ] [ depth>> ] bi ; : spider-next-page ( spider -- ) @@ -138,5 +138,5 @@ PRIVATE> : run-spider ( spider -- spider ) "spider" [ - queue-initial-links [ run-spider-loop ] keep + dup queue-initial-links [ run-spider-loop ] keep ] with-logging ; From 95f304bee0a8aa0654c1369bf0a06b15745dbcea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 3 Apr 2009 21:16:27 -0500 Subject: [PATCH 45/73] Check in spider.report --- extra/spider/report/authors.txt | 1 + extra/spider/report/report.factor | 113 ++++++++++++++++++++++++++++++ 2 files changed, 114 insertions(+) create mode 100644 extra/spider/report/authors.txt create mode 100644 extra/spider/report/report.factor diff --git a/extra/spider/report/authors.txt b/extra/spider/report/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/spider/report/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/spider/report/report.factor b/extra/spider/report/report.factor new file mode 100644 index 0000000000..8bb4f91f82 --- /dev/null +++ b/extra/spider/report/report.factor @@ -0,0 +1,113 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs combinators kernel math +math.statistics namespaces sequences sorting xml.syntax +spider ; +IN: spider.report + +SYMBOL: network-failures +SYMBOL: broken-pages +SYMBOL: timings + +: record-broken-page ( url spider-result -- ) + headers>> [ code>> ] [ message>> ] bi 2array 2array + broken-pages push ; + +: record-page-timings ( url spider-result -- ) + fetch-time>> 2array timings get push ; + +: record-network-failure ( url -- ) + network-failures get push ; + +: process-result ( url spider-result -- ) + { + { f [ record-network-failure ] } + [ + dup headers>> code>> 200 = + [ record-page-timings ] [ record-broken-page ] if + ] + } case ; + +CONSTANT: slowest 5 + +SYMBOL: slowest-pages +SYMBOL: mean-time +SYMBOL: median-time +SYMBOL: time-std + +: process-timings ( -- ) + timings get sort-values + [ slowest short tail* reverse slowest-pages set ] + [ + values + [ mean 1000000 /f mean-time set ] + [ median 1000000 /f median-time set ] + [ std 1000000 /f time-std set ] tri + ] bi ; + +: process-results ( results -- ) + V{ } clone network-failures set + V{ } clone broken-pages set + V{ } clone timings set + [ process-result ] assoc-each + process-timings ; + +: info-table ( alist -- html ) + [ + first2 dupd 1000000 /f + [XML + ><-><-> seconds + XML] + ] map [XML <->
XML] ; + +: report-broken-pages ( -- html ) + broken-pages get info-table ; + +: report-network-failures ( -- html ) + network-failures get [ + dup [XML
  • ><->
    • XML] + ] map [XML
      <->
    XML] ; + +: slowest-pages-table ( -- html ) + slowest-pages get info-table ; + +: timing-summary-table ( -- html ) + mean-time get + median-time get + time-std get + [XML + + + + +
    Mean<-> seconds
    Median<-> seconds
    Standard deviation<-> seconds
    + XML] ; + +: report-timings ( -- html ) + slowest-pages-table + timing-summary-table + [XML +

    Slowest pages

    + <-> + +

    Summary

    + <-> + XML] ; + +: generate-report ( -- html ) + report-broken-pages + report-network-failures + report-timings + [XML +

    Broken pages

    + <-> + +

    Network failures

    + <-> + +

    Load times

    + <-> + XML] ; + +: spider-report ( spider -- html ) + [ spidered>> process-results generate-report ] with-scope ; From 6f2c4fc02a137c92edc0ae7a677f9e0bcc11f3fb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 4 Apr 2009 00:02:15 -0500 Subject: [PATCH 46/73] slim down the sorting.functor using more combinators --- basis/sorting/functor/functor.factor | 8 ------ basis/sorting/human/human-docs.factor | 35 -------------------------- basis/sorting/human/human-tests.factor | 4 +-- basis/sorting/slots/slots.factor | 10 ++++++-- basis/sorting/title/title-tests.factor | 4 +-- 5 files changed, 12 insertions(+), 49 deletions(-) diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor index 022ef3fb0d..7f46af4c92 100644 --- a/basis/sorting/functor/functor.factor +++ b/basis/sorting/functor/functor.factor @@ -7,18 +7,10 @@ FUNCTOR: define-sorting ( NAME QUOT -- ) NAME<=> DEFINES ${NAME}<=> NAME>=< DEFINES ${NAME}>=< -NAME-compare DEFINES ${NAME}-compare -NAME-sort DEFINES ${NAME}-sort -NAME-sort-keys DEFINES ${NAME}-sort-keys -NAME-sort-values DEFINES ${NAME}-sort-values WHERE : NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ; : NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ; -: NAME-compare ( obj1 obj2 quot -- <=> ) bi@ NAME<=> ; inline -: NAME-sort ( seq -- sortedseq ) [ NAME<=> ] sort ; -: NAME-sort-keys ( seq -- sortedseq ) [ [ first ] NAME-compare ] sort ; -: NAME-sort-values ( seq -- sortedseq ) [ [ second ] NAME-compare ] sort ; ;FUNCTOR diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor index 606eef670a..4bb62b1313 100644 --- a/basis/sorting/human/human-docs.factor +++ b/basis/sorting/human/human-docs.factor @@ -25,46 +25,11 @@ HELP: human>=< } { $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ; -HELP: human-compare -{ $values - { "obj1" object } { "obj2" object } { "quot" quotation } - { "<=>" "an ordering specifier" } -} -{ $description "Compares the results of applying the quotation to both objects via <=>." } ; - -HELP: human-sort -{ $values - { "seq" sequence } - { "sortedseq" sequence } -} -{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ; - -HELP: human-sort-keys -{ $values - { "seq" "an alist" } - { "sortedseq" "a new sorted sequence" } -} -{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ; - -HELP: human-sort-values -{ $values - { "seq" "an alist" } - { "sortedseq" "a new sorted sequence" } -} -{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ; - -{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words - ARTICLE: "sorting.human" "Human-friendly sorting" "The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl "Comparing two objects:" { $subsection human<=> } { $subsection human>=< } -{ $subsection human-compare } -"Sort a sequence:" -{ $subsection human-sort } -{ $subsection human-sort-keys } -{ $subsection human-sort-values } "Splitting a string into substrings and integers:" { $subsection find-numbers } ; diff --git a/basis/sorting/human/human-tests.factor b/basis/sorting/human/human-tests.factor index 0e20b54c2f..519e0064b6 100644 --- a/basis/sorting/human/human-tests.factor +++ b/basis/sorting/human/human-tests.factor @@ -1,6 +1,6 @@ -USING: sorting.human tools.test ; +USING: sorting.human tools.test sorting.slots ; IN: sorting.human.tests \ human-sort must-infer -[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test +[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 2dccc60821..26458bb22c 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -7,8 +7,8 @@ IN: sorting.slots } sort-by ] unit-test From e929c397d1e8b12096bb4a05e9c06a37c54a488b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 4 Apr 2009 11:57:23 -0500 Subject: [PATCH 47/73] refactoring spider --- extra/spider/report/report.factor | 2 +- extra/spider/spider.factor | 29 ++++--------------- extra/spider/unique-deque/authors.txt | 1 + extra/spider/unique-deque/unique-deque.factor | 24 +++++++++++++++ 4 files changed, 31 insertions(+), 25 deletions(-) create mode 100644 extra/spider/unique-deque/authors.txt create mode 100644 extra/spider/unique-deque/unique-deque.factor diff --git a/extra/spider/report/report.factor b/extra/spider/report/report.factor index 8bb4f91f82..43952701d5 100644 --- a/extra/spider/report/report.factor +++ b/extra/spider/report/report.factor @@ -14,7 +14,7 @@ SYMBOL: timings broken-pages push ; : record-page-timings ( url spider-result -- ) - fetch-time>> 2array timings get push ; + fetched-in>> 2array timings get push ; : record-network-failure ( url -- ) network-failures get push ; diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 07989860ff..39ee3b5d7b 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -4,12 +4,13 @@ USING: accessors fry html.parser html.parser.analyzer http.client kernel tools.time sets assocs sequences concurrency.combinators io threads namespaces math multiline math.parser inspector urls logging combinators.short-circuit -continuations calendar prettyprint dlists deques locals ; +continuations calendar prettyprint dlists deques locals +spider.unique-deque ; IN: spider TUPLE: spider base count max-count sleep max-depth initial-links filters spidered todo nonmatching quiet currently-spidering -#threads follow-robots ; +#threads follow-robots? robots ; TUPLE: spider-result url depth headers fetched-in parsed-html links processed-in fetched-at ; @@ -21,26 +22,6 @@ TUPLE: todo-url url depth ; swap >>depth swap >>url ; -TUPLE: unique-deque assoc deque ; - -: ( -- unique-deque ) - H{ } clone unique-deque boa ; - -: url-exists? ( url unique-deque -- ? ) - [ url>> ] [ assoc>> ] bi* key? ; - -: push-url ( url depth unique-deque -- ) - [ ] dip 2dup url-exists? [ - 2drop - ] [ - [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ] - [ deque>> push-back ] 2bi - ] if ; - -: pop-url ( unique-deque -- todo-url ) deque>> pop-front ; - -: peek-url ( unique-deque -- todo-url ) deque>> peek-front ; - : ( base -- spider ) >url spider new @@ -89,13 +70,13 @@ TUPLE: unique-deque assoc deque ; :: new-spidered-result ( spider url depth -- spider-result ) f url spider spidered>> set-at - [ url http-get ] benchmark :> fetch-time :> html :> headers + [ url http-get ] benchmark :> fetched-at :> html :> headers [ html parse-html spider currently-spidering>> over find-all-links normalize-hrefs ] benchmark :> processing-time :> links :> parsed-html - url depth headers fetch-time parsed-html links processing-time + url depth headers fetched-at parsed-html links processing-time now spider-result boa ; :: spider-page ( spider url depth -- ) diff --git a/extra/spider/unique-deque/authors.txt b/extra/spider/unique-deque/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/spider/unique-deque/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor new file mode 100644 index 0000000000..28d92633d1 --- /dev/null +++ b/extra/spider/unique-deque/unique-deque.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs deques dlists kernel spider ; +IN: spider.unique-deque + +TUPLE: unique-deque assoc deque ; + +: ( -- unique-deque ) + H{ } clone unique-deque boa ; + +: url-exists? ( url unique-deque -- ? ) + [ url>> ] [ assoc>> ] bi* key? ; + +: push-url ( url depth unique-deque -- ) + [ ] dip 2dup url-exists? [ + 2drop + ] [ + [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ] + [ deque>> push-back ] 2bi + ] if ; + +: pop-url ( unique-deque -- todo-url ) deque>> pop-front ; + +: peek-url ( unique-deque -- todo-url ) deque>> peek-front ; From 12fa6ac5a523b6647657bcddf0de451c94b14d12 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 4 Apr 2009 14:24:44 -0500 Subject: [PATCH 48/73] remove empty file --- basis/core-graphics/core-graphics-docs.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 basis/core-graphics/core-graphics-docs.factor diff --git a/basis/core-graphics/core-graphics-docs.factor b/basis/core-graphics/core-graphics-docs.factor deleted file mode 100644 index e69de29bb2..0000000000 From a4f4abe19e4d22e43f4d44d0d9cefc4281d5f05c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 4 Apr 2009 14:25:37 -0500 Subject: [PATCH 49/73] remove empty file --- build-support/dlls.txt | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 build-support/dlls.txt diff --git a/build-support/dlls.txt b/build-support/dlls.txt deleted file mode 100644 index e69de29bb2..0000000000 From b549bd6cc9dd82ce1aeab6925d8128cf86a79932 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 4 Apr 2009 22:34:21 +0200 Subject: [PATCH 50/73] FUEL: More robust extract word refactoring (catching empty region case). --- misc/fuel/fuel-refactor.el | 55 +++++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 24 deletions(-) diff --git a/misc/fuel/fuel-refactor.el b/misc/fuel/fuel-refactor.el index 942d439466..a410bb5047 100644 --- a/misc/fuel/fuel-refactor.el +++ b/misc/fuel/fuel-refactor.el @@ -36,7 +36,7 @@ (let ((name (match-string-no-properties 2)) (body (match-string-no-properties 4)) (end (match-end 0))) - (list (split-string body nil t) name pos end))))) + (list (split-string (or body "") nil t) name pos end))))) (defun fuel-refactor--find (code to) (let ((candidate) (result)) @@ -88,7 +88,7 @@ (defun fuel-refactor--insert-word (word stack-effect code) (let ((start (goto-char (fuel-refactor--insertion-point)))) (open-line 1) - (insert ": " word " " stack-effect "\n" code " ;\n") + (insert ": " word " " stack-effect "\n" (or code " ") " ;\n") (indent-region start (point)) (move-overlay fuel-stack--overlay start (point)))) @@ -103,39 +103,46 @@ (delete-overlay fuel-stack--overlay))) (defun fuel-refactor--extract (begin end) - (unless (< begin end) (error "No proper region to extract")) - (let* ((code (buffer-substring begin end)) - (existing (fuel-refactor--reuse-existing code)) - (code-str (or existing (fuel--region-to-string begin end))) + (let* ((rp (< begin end)) + (code (and rp (buffer-substring begin end))) + (existing (and code (fuel-refactor--reuse-existing code))) + (code-str (and code (or existing (fuel--region-to-string begin end)))) (word (or (car existing) (read-string "New word name: "))) (stack-effect (or existing - (fuel-stack--infer-effect code-str) + (and code-str (fuel-stack--infer-effect code-str)) (read-string "Stack effect: ")))) - (goto-char begin) - (delete-region begin end) - (insert word) - (indent-region begin (point)) + (when rp + (goto-char begin) + (delete-region begin end) + (insert word) + (indent-region begin (point))) (save-excursion (let ((start (or (cadr existing) (point)))) (unless existing (fuel-refactor--insert-word word stack-effect code)) - (fuel-refactor--extract-other start - (or (car (cddr existing)) (point)) - code))))) + (if rp + (fuel-refactor--extract-other start + (or (car (cddr existing)) (point)) + code) + (unwind-protect + (sit-for fuel-stack-highlight-period) + (delete-overlay fuel-stack--overlay))))))) (defun fuel-refactor-extract-region (begin end) "Extracts current region as a separate word." (interactive "r") - (let ((begin (save-excursion - (goto-char begin) - (when (zerop (skip-syntax-backward "w")) - (skip-syntax-forward "-")) - (point))) - (end (save-excursion - (goto-char end) - (skip-syntax-forward "w") - (point)))) - (fuel-refactor--extract begin end))) + (if (= begin end) + (fuel-refactor--extract begin end) + (let ((begin (save-excursion + (goto-char begin) + (when (zerop (skip-syntax-backward "w")) + (skip-syntax-forward "-")) + (point))) + (end (save-excursion + (goto-char end) + (skip-syntax-forward "w") + (point)))) + (fuel-refactor--extract begin end)))) (defun fuel-refactor-extract-sexp () "Extracts current innermost sexp (up to point) as a separate From 5fd9f446e7aa6b6720e46e8ad16df7a769b32f4d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 4 Apr 2009 15:45:56 -0500 Subject: [PATCH 51/73] use more macros in sorting, fix test --- basis/sorting/human/human-tests.factor | 2 -- basis/sorting/slots/slots.factor | 14 +++++++------- 2 files changed, 7 insertions(+), 9 deletions(-) diff --git a/basis/sorting/human/human-tests.factor b/basis/sorting/human/human-tests.factor index 519e0064b6..20a607188c 100644 --- a/basis/sorting/human/human-tests.factor +++ b/basis/sorting/human/human-tests.factor @@ -1,6 +1,4 @@ USING: sorting.human tools.test sorting.slots ; IN: sorting.human.tests -\ human-sort must-infer - [ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index 26458bb22c..efec960c27 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -8,7 +8,7 @@ IN: sorting.slots ) #! sort-spec: { accessors comparator } [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; -: sort-by-slots ( seq sort-specs -- sortedseq ) - '[ _ compare-slots ] sort ; +MACRO: sort-by-slots ( sort-specs -- quot ) + '[ [ _ compare-slots ] sort ] ; MACRO: compare-seq ( seq -- quot ) [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; -: sort-by ( seq sort-seq -- sortedseq ) - '[ _ compare-seq ] sort ; +MACRO: sort-by ( sort-seq -- quot ) + '[ [ _ compare-seq ] sort ] ; -: sort-keys-by ( seq sort-seq -- sortedseq ) +MACRO: sort-keys-by ( sort-seq -- quot ) '[ [ first ] bi@ _ compare-seq ] sort ; -: sort-values-by ( seq sort-seq -- sortedseq ) +MACRO: sort-values-by ( sort-seq -- quot ) '[ [ second ] bi@ _ compare-seq ] sort ; MACRO: split-by-slots ( accessor-seqs -- quot ) From 26dccb5b1683102c74b799c30fb5a6d2a1045ee5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 4 Apr 2009 15:46:18 -0500 Subject: [PATCH 52/73] human-sort is now { human<=> } sort-by --- extra/color-table/color-table.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/color-table/color-table.factor b/extra/color-table/color-table.factor index 13a516eaf1..0865dabcf7 100644 --- a/extra/color-table/color-table.factor +++ b/extra/color-table/color-table.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors combinators.smart sorting.human -models colors.constants present +models colors.constants present sorting.slots ui ui.gadgets.tables ui.gadgets.scrollers ; IN: color-table @@ -29,7 +29,7 @@ M: color-renderer row-value drop named-color ; : ( -- table ) - named-colors human-sort + named-colors { human<=> } sort-by color-renderer 5 >>gap @@ -40,4 +40,4 @@ M: color-renderer row-value : color-table-demo ( -- ) [ "Colors" open-window ] with-ui ; -MAIN: color-table-demo \ No newline at end of file +MAIN: color-table-demo From 284511a2e796953306ed66217fc8a889b5abb8f5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 4 Apr 2009 15:47:17 -0500 Subject: [PATCH 53/73] fix load erro --- extra/spider/spider.factor | 7 ------- extra/spider/unique-deque/unique-deque.factor | 7 +++++++ 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor index 39ee3b5d7b..49d6c33f8f 100644 --- a/extra/spider/spider.factor +++ b/extra/spider/spider.factor @@ -15,13 +15,6 @@ filters spidered todo nonmatching quiet currently-spidering TUPLE: spider-result url depth headers fetched-in parsed-html links processed-in fetched-at ; -TUPLE: todo-url url depth ; - -: ( url depth -- todo-url ) - todo-url new - swap >>depth - swap >>url ; - : ( base -- spider ) >url spider new diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor index 28d92633d1..ad46abdad3 100644 --- a/extra/spider/unique-deque/unique-deque.factor +++ b/extra/spider/unique-deque/unique-deque.factor @@ -3,6 +3,13 @@ USING: accessors assocs deques dlists kernel spider ; IN: spider.unique-deque +TUPLE: todo-url url depth ; + +: ( url depth -- todo-url ) + todo-url new + swap >>depth + swap >>url ; + TUPLE: unique-deque assoc deque ; : ( -- unique-deque ) From b4a74f55a3506a5abe083f99f259edfdb8497495 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 19:57:48 -0500 Subject: [PATCH 54/73] Add hashcode method for simple-alien; improves performance of malloc and free --- core/alien/alien.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index ea0cb9208e..05f5223548 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -49,6 +49,8 @@ M: alien equal? 2drop f ] if ; +M: simple-alien hashcode* nip alien-address ; + ERROR: alien-callback-error ; : alien-callback ( return parameters abi quot -- alien ) From e84cc5f82d47a3c6d1db369bf0f8334b3598f548 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:03:30 -0500 Subject: [PATCH 55/73] Simplify do-matrix --- basis/opengl/opengl-docs.factor | 4 ++-- basis/opengl/opengl.factor | 8 ++++---- basis/ui/text/text.factor | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor index f474c97b73..b773833280 100644 --- a/basis/opengl/opengl-docs.factor +++ b/basis/opengl/opengl-docs.factor @@ -15,8 +15,8 @@ HELP: do-enabled { $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ; HELP: do-matrix -{ $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } } -{ $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ; +{ $values { "quot" quotation } } +{ $description "Saves and restores the current matrix before and after calling the quotation." } ; HELP: gl-line { $values { "a" "a pair of integers" } { "b" "a pair of integers" } } diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 0a21f67376..c60917b42a 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -44,9 +44,8 @@ MACRO: all-enabled ( seq quot -- ) MACRO: all-enabled-client-state ( seq quot -- ) [ words>values ] dip '[ _ _ (all-enabled-client-state) ] ; -: do-matrix ( mode quot -- ) - swap [ glMatrixMode glPushMatrix call ] keep - glMatrixMode glPopMatrix ; inline +: do-matrix ( quot -- ) + glPushMatrix call glPopMatrix ; inline : gl-material ( face pname params -- ) float-array{ } like glMaterialfv ; @@ -165,7 +164,7 @@ MACRO: set-draw-buffers ( buffers -- ) : delete-dlist ( id -- ) 1 glDeleteLists ; : with-translation ( loc quot -- ) - GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline + [ [ gl-translate ] dip call ] do-matrix ; inline : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 ) [ first2 [ >fixnum ] bi@ ] bi@ ; @@ -177,6 +176,7 @@ MACRO: set-draw-buffers ( buffers -- ) fix-coordinates glViewport ; : init-matrices ( -- ) + #! Leaves with matrix mode GL_MODELVIEW GL_PROJECTION glMatrixMode glLoadIdentity GL_MODELVIEW glMatrixMode diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor index d787fe8ea9..2edb20fc22 100755 --- a/basis/ui/text/text.factor +++ b/basis/ui/text/text.factor @@ -66,7 +66,7 @@ M: string draw-text draw-string ; M: selection draw-text draw-string ; M: array draw-text - GL_MODELVIEW [ + [ [ [ draw-string ] [ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi From 1a4f2724e40e7ee16e71fea20d4866e16cd32212 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:03:44 -0500 Subject: [PATCH 56/73] Don't call glFlush, it's useless --- basis/ui/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 76fbc7286b..d72ef13b44 100755 --- a/basis/ui/backend/backend.factor +++ b/basis/ui/backend/backend.factor @@ -29,6 +29,6 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h ) : with-gl-context ( handle quot -- ) swap [ select-gl-context call ] keep - glFlush flush-gl-context gl-error ; inline + flush-gl-context gl-error ; inline HOOK: (with-ui) ui-backend ( quot -- ) \ No newline at end of file From 0affe96d959c414e99b350e4aff92067ef6a433b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:04:35 -0500 Subject: [PATCH 57/73] opengl.textures: pad image up to a power of 2 using glTexSubImage2D instead of doing it in Factor code --- basis/opengl/textures/textures.factor | 89 +++++++++--------------- basis/ui/images/images.factor | 2 +- basis/ui/text/core-text/core-text.factor | 4 +- basis/ui/text/pango/pango.factor | 4 +- basis/ui/text/uniscribe/uniscribe.factor | 2 +- basis/windows/uniscribe/uniscribe.factor | 5 +- 6 files changed, 36 insertions(+), 70 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 3efe924fb5..cdd421ddde 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs cache colors.constants destructors fry kernel opengl opengl.gl combinators images images.tesselation grouping -specialized-arrays.float locals sequences math math.vectors -math.matrices generalizations fry columns arrays ; +specialized-arrays.float sequences math math.vectors +math.matrices generalizations fry arrays ; IN: opengl.textures : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; @@ -19,61 +19,42 @@ M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ; M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ; -GENERIC: draw-texture ( texture -- ) +SLOT: display-list + +: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ; GENERIC: draw-scaled-texture ( dim texture -- ) > first2 [ next-power-of-2 ] bi@ 0 ] + [ component-order>> component-order>format f ] bi + glTexImage2D ; -: power-of-2-bitmap ( rows dim size -- bitmap dim ) - '[ - first2 - [ [ _ ] dip '[ _ group _ repeat-last ] map ] - [ repeat-last ] - bi* - ] keep ; +: (tex-sub-image) ( image -- ) + [ GL_TEXTURE_2D 0 0 0 ] dip + [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri + glTexSubImage2D ; -: image-rows ( image -- rows ) - [ bitmap>> ] - [ dim>> first ] - [ component-order>> bytes-per-pixel ] - tri * group ; inline - -: power-of-2-image ( image -- image ) - dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [ - clone dup - [ image-rows ] - [ dim>> [ next-power-of-2 ] map ] - [ component-order>> bytes-per-pixel ] tri - power-of-2-bitmap - [ >>bitmap ] [ >>dim ] bi* - ] unless ; - -:: make-texture ( image -- id ) +: make-texture ( image -- id ) + #! We use glTexSubImage2D to work around the power of 2 texture size + #! limitation gen-texture [ GL_TEXTURE_BIT [ GL_TEXTURE_2D swap glBindTexture - GL_TEXTURE_2D - 0 - GL_RGBA - image dim>> first2 - 0 - image component-order>> component-order>format - image bitmap>> - glTexImage2D + [ (tex-image) ] [ (tex-sub-image) ] bi ] do-attribs ] keep ; : init-texture ( -- ) - GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ; + GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; : with-texturing ( quot -- ) GL_TEXTURE_2D [ @@ -101,7 +82,7 @@ TUPLE: single-texture image loc dim texture-coords texture display-list disposed : texture-coords ( texture -- coords ) [ - [ dim>> ] [ image>> dim>> ] bi v/ + [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map ] keep @@ -111,9 +92,8 @@ TUPLE: single-texture image loc dim texture-coords texture display-list disposed : make-texture-display-list ( texture -- dlist ) GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ; -: ( image loc dim -- texture ) - [ power-of-2-image ] 2dip - single-texture new swap >>dim swap >>loc swap >>image +: ( image loc -- texture ) + single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi dup image>> dim>> product 0 = [ dup texture-coords >>texture-coords dup image>> make-texture >>texture @@ -124,21 +104,19 @@ M: single-texture dispose* [ texture>> [ delete-texture ] when* ] [ display-list>> [ delete-dlist ] when* ] bi ; -M: single-texture draw-texture display-list>> [ glCallList ] when* ; - M: single-texture draw-scaled-texture dup texture>> [ draw-textured-rect ] [ 2drop ] if ; TUPLE: multi-texture grid display-list loc disposed ; : image-locs ( image-grid -- loc-grid ) - [ first [ dim>> first ] map ] [ 0 [ dim>> second ] map ] bi + [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi [ 0 [ + ] accumulate nip ] bi@ cross-zip flip ; : ( image-grid loc -- grid ) [ dup image-locs ] dip - '[ [ _ v+ over dim>> |dispose ] 2map ] 2map ; + '[ [ _ v+ |dispose ] 2map ] 2map ; : draw-textured-grid ( grid -- ) [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ; @@ -165,18 +143,13 @@ TUPLE: multi-texture grid display-list loc disposed ; f multi-texture boa ] with-destructors ; -M: multi-texture draw-texture display-list>> [ glCallList ] when* ; - M: multi-texture dispose* grid>> [ [ dispose ] each ] each ; CONSTANT: max-texture-size { 512 512 } PRIVATE> -: small-texture? ( dim -- ? ) - max-texture-size [ <= ] 2all? ; - -: ( image loc dim -- texture ) - pick dim>> small-texture? +: ( image loc -- texture ) + over dim>> max-texture-size [ <= ] 2all? [ ] - [ drop [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file + [ [ max-texture-size tesselate ] dip ] if ; \ No newline at end of file diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor index 8e36f2a3b1..2b1caa8ab9 100755 --- a/basis/ui/images/images.factor +++ b/basis/ui/images/images.factor @@ -20,7 +20,7 @@ PRIVATE> : rendered-image ( path -- texture ) world get image-texture-cache - [ cached-image [ { 0 0 } ] keep dim>> ] cache ; + [ cached-image { 0 0 } ] cache ; : draw-image ( image-name -- ) rendered-image draw-texture ; diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor index 404624da95..0d720ac0b1 100755 --- a/basis/ui/text/core-text/core-text.factor +++ b/basis/ui/text/core-text/core-text.factor @@ -20,9 +20,7 @@ M: core-text-renderer flush-layout-cache : rendered-line ( font string -- texture ) world get world-text-handle [ - cached-line - [ image>> ] [ loc>> ] [ image>> dim>> ] tri - + cached-line [ image>> ] [ loc>> ] bi ] 2cache ; M: core-text-renderer draw-string ( font string -- ) diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor index 46328d11d5..92c4fe5c75 100755 --- a/basis/ui/text/pango/pango.factor +++ b/basis/ui/text/pango/pango.factor @@ -16,9 +16,7 @@ M: pango-renderer flush-layout-cache : rendered-layout ( font string -- texture ) world get world-text-handle [ - cached-layout - [ image>> ] [ text-position vneg ] [ image>> dim>> ] tri - + cached-layout [ image>> ] [ text-position vneg ] bi ] 2cache ; M: pango-renderer draw-string ( font string -- ) diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor index dcec4ab17e..d56da86b86 100755 --- a/basis/ui/text/uniscribe/uniscribe.factor +++ b/basis/ui/text/uniscribe/uniscribe.factor @@ -16,7 +16,7 @@ M: uniscribe-renderer flush-layout-cache : rendered-script-string ( font string -- texture ) world get world-text-handle - [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi ] + [ cached-script-string image>> { 0 0 } ] 2cache ; M: uniscribe-renderer draw-string ( font string -- ) diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor index 53d2d9918f..7cfda41dc9 100755 --- a/basis/windows/uniscribe/uniscribe.factor +++ b/basis/windows/uniscribe/uniscribe.factor @@ -71,11 +71,8 @@ TUPLE: script-string font string metrics ssa size image disposed ; : draw-script-string ( dc script-string -- ) [ font>> set-dc-colors ] keep (draw-script-string) ; -: script-string-bitmap-size ( script-string -- dim ) - size>> dup small-texture? [ [ next-power-of-2 ] map ] when ; - :: make-script-string-image ( dc script-string -- image ) - script-string script-string-bitmap-size dc + script-string size>> dc [ dc script-string draw-script-string ] make-bitmap-image ; : set-dc-font ( dc font -- ) From 10404265654959fb18586d3c2d07150ed64841fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:21:41 -0500 Subject: [PATCH 58/73] Fix alien hashcode for expired aliens --- core/alien/alien-tests.factor | 4 +++- core/alien/alien.factor | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 57dc298c00..aa65a3e2d8 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,6 +1,6 @@ USING: accessors alien alien.accessors alien.syntax byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math -system prettyprint layouts alien.libraries ; +system prettyprint layouts alien.libraries sets ; IN: alien.tests [ t ] [ -1 alien-address 0 > ] unit-test @@ -86,3 +86,5 @@ f initialize-test set-global [ ] [ initialize-test get BAD-ALIEN >>alien drop ] unit-test [ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test + +[ { BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test \ No newline at end of file diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 05f5223548..ec38e3be5b 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -49,7 +49,7 @@ M: alien equal? 2drop f ] if ; -M: simple-alien hashcode* nip alien-address ; +M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ; ERROR: alien-callback-error ; From d707292d8488f5d41f7c4a7d5cecff3aaaf19b68 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:22:49 -0500 Subject: [PATCH 59/73] Fix documentation for map-index --- core/sequences/sequences-docs.factor | 2 +- core/sequences/sequences.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index c171555737..e2badc2031 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -311,7 +311,7 @@ HELP: each-index HELP: map-index { $values - { "seq" sequence } { "quot" quotation } } + { "seq" sequence } { "quot" quotation } { "newseq" sequence } } { $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." } { $examples { $example "USING: sequences prettyprint math ;" "{ 10 20 30 } [ + ] map-index ." diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index f352705e85..564309a6fb 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -506,7 +506,7 @@ PRIVATE> [ [ 0 = ] 2dip if ] 2curry each-index ; inline -: map-index ( seq quot -- ) +: map-index ( seq quot -- newseq ) prepare-index 2map ; inline : reduce-index ( seq identity quot -- ) From f44c67e5c307103abd550e49d2cd05f1c26bb8fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 20:34:09 -0500 Subject: [PATCH 60/73] mason.test: check if boot image is out of date, and refuse to build if so --- extra/mason/test/test.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index a15a96c63e..bc00f659fa 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -4,7 +4,7 @@ USING: accessors assocs benchmark bootstrap.stage2 compiler.errors generic help.html help.lint io.directories io.encodings.utf8 io.files kernel mason.common math namespaces prettyprint sequences sets sorting tools.test tools.time -tools.vocabs words ; +tools.vocabs words system io ; IN: mason.test : do-load ( -- ) @@ -44,9 +44,19 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline +: check-boot-image ( -- ) + "" to-refresh drop 2dup [ empty? not ] either? + [ + "Boot image is out of date. Changed vocabs:" print + append prune [ print ] each + flush + 1 exit + ] [ 2drop ] if ; + : do-all ( -- ) ".." [ bootstrap-time get boot-time-file to-file + check-boot-image [ do-load do-compile-errors ] benchmark-ms load-time-file to-file [ generate-help ] benchmark-ms html-help-time-file to-file [ do-tests ] benchmark-ms test-time-file to-file From fb6c5141ecfc0876169146a30f0630d33986fa01 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 4 Apr 2009 22:38:49 -0500 Subject: [PATCH 61/73] Fixing this for Windows --- basis/opengl/textures/textures.factor | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index cdd421ddde..bb22b4351c 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -53,8 +53,8 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed : init-texture ( -- ) GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ; : with-texturing ( quot -- ) GL_TEXTURE_2D [ @@ -82,11 +82,15 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed : texture-coords ( texture -- coords ) [ - [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ - { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } + [ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ] + [ + image>> upside-down?>> + { { 0 1 } { 1 1 } { 1 0 } { 0 0 } } + { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ? + ] bi [ v* ] with map ] keep - image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when + drop ! image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when float-array{ } join ; : make-texture-display-list ( texture -- dlist ) From 52060e625396b4ce6b98cba6779044ad09813144 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 4 Apr 2009 22:45:02 -0500 Subject: [PATCH 62/73] Oops dead code --- basis/opengl/textures/textures.factor | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index bb22b4351c..bb232affa4 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -81,17 +81,13 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed ] with-texturing ; : texture-coords ( texture -- coords ) + [ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ] [ - [ [ dim>> ] [ image>> dim>> [ next-power-of-2 ] map ] bi v/ ] - [ - image>> upside-down?>> - { { 0 1 } { 1 1 } { 1 0 } { 0 0 } } - { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ? - ] bi - [ v* ] with map - ] keep - drop ! image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when - float-array{ } join ; + image>> upside-down?>> + { { 0 1 } { 1 1 } { 1 0 } { 0 0 } } + { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ? + ] bi + [ v* ] with map float-array{ } join ; : make-texture-display-list ( texture -- dlist ) GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ; From 1023fa51f4427c6a89b45fbeb87863939b9da703 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 4 Apr 2009 23:04:53 -0500 Subject: [PATCH 63/73] Fix mailbox-get-all, and make mailbox timeouts throw a wait-timeout error instead of a string --- basis/concurrency/conditions/conditions.factor | 4 +++- .../concurrency/mailboxes/mailboxes-tests.factor | 16 ++++++++++++++-- basis/concurrency/mailboxes/mailboxes.factor | 2 +- 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 11e624110c..ad00bbdfa9 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -20,10 +20,12 @@ IN: concurrency.conditions ] ] dip later ; +ERROR: wait-timeout ; + : wait ( queue timeout status -- ) over [ [ queue-timeout [ drop ] ] dip suspend - [ "Timeout" throw ] [ cancel-alarm ] if + [ wait-timeout ] [ cancel-alarm ] if ] [ [ drop '[ _ push-front ] ] dip suspend drop ] if ; diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor index 64971eeb77..81e54f1807 100644 --- a/basis/concurrency/mailboxes/mailboxes-tests.factor +++ b/basis/concurrency/mailboxes/mailboxes-tests.factor @@ -1,6 +1,6 @@ IN: concurrency.mailboxes.tests -USING: concurrency.mailboxes concurrency.count-downs vectors -sequences threads tools.test math kernel strings namespaces +USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions +vectors sequences threads tools.test math kernel strings namespaces continuations calendar destructors ; { 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as @@ -75,3 +75,15 @@ continuations calendar destructors ; [ ] [ "d" get 5 seconds await-timeout ] unit-test [ ] [ "m" get dispose ] unit-test + +[ { "foo" "bar" } ] [ + + "foo" over mailbox-put + "bar" over mailbox-put + mailbox-get-all +] unit-test + +[ + 1 seconds mailbox-get-timeout +] [ wait-timeout? ] must-fail-with + \ No newline at end of file diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index f6aec94b41..200adb14ae 100755 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -49,7 +49,7 @@ M: mailbox dispose* threads>> notify-all ; : mailbox-get-all-timeout ( mailbox timeout -- array ) block-if-empty - [ dup mailbox-empty? ] + [ dup mailbox-empty? not ] [ dup data>> pop-back ] produce nip ; From b0b77cf744d26c5c861402a7bb7dd7ed2deda60e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 17:32:53 -0500 Subject: [PATCH 64/73] Fixes for recent changes --- basis/opengl/textures/textures-tests.factor | 50 --------------------- extra/tetris/gl/gl.factor | 2 +- 2 files changed, 1 insertion(+), 51 deletions(-) diff --git a/basis/opengl/textures/textures-tests.factor b/basis/opengl/textures/textures-tests.factor index 163871028d..3efdb43cd8 100644 --- a/basis/opengl/textures/textures-tests.factor +++ b/basis/opengl/textures/textures-tests.factor @@ -5,56 +5,6 @@ opengl.textures.private images kernel namespaces accessors sequences ; IN: opengl.textures.tests -[ ] [ - T{ image - { dim { 3 5 } } - { component-order RGB } - { bitmap - B{ - 1 2 3 4 5 6 7 8 9 - 10 11 12 13 14 15 16 17 18 - 19 20 21 22 23 24 25 26 27 - 28 29 30 31 32 33 34 35 36 - 37 38 39 40 41 42 43 44 45 - } - } - } "image" set -] unit-test - -[ - T{ image - { dim { 4 8 } } - { component-order RGB } - { bitmap - B{ - 1 2 3 4 5 6 7 8 9 7 8 9 - 10 11 12 13 14 15 16 17 18 16 17 18 - 19 20 21 22 23 24 25 26 27 25 26 27 - 28 29 30 31 32 33 34 35 36 34 35 36 - 37 38 39 40 41 42 43 44 45 43 44 45 - 37 38 39 40 41 42 43 44 45 43 44 45 - 37 38 39 40 41 42 43 44 45 43 44 45 - 37 38 39 40 41 42 43 44 45 43 44 45 - } - } - } -] [ - "image" get power-of-2-image -] unit-test - -[ - T{ image - { dim { 0 0 } } - { component-order R32G32B32 } - { bitmap B{ } } } -] [ - T{ image - { dim { 0 0 } } - { component-order R32G32B32 } - { bitmap B{ } } - } power-of-2-image -] unit-test - [ { { { 0 0 } { 10 0 } } diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor index d1f398994e..0169249e81 100644 --- a/extra/tetris/gl/gl.factor +++ b/extra/tetris/gl/gl.factor @@ -37,7 +37,7 @@ IN: tetris.gl : draw-tetris ( width height tetris -- ) #! width and height are in pixels - GL_MODELVIEW [ + [ { [ board>> scale-board ] [ board>> draw-board ] From 75dd35179b48290b2725912404c725407d7f0a59 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 17:34:02 -0500 Subject: [PATCH 65/73] Fix alien unit tests --- core/alien/alien-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index aa65a3e2d8..d3265f31bb 100644 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -87,4 +87,4 @@ f initialize-test set-global [ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test -[ { BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test \ No newline at end of file +[ V{ BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test \ No newline at end of file From 87121c1468063196b3a210369ecc1fe1f8798dc6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 20:44:12 -0500 Subject: [PATCH 66/73] Fix prettyprinting of URLs --- basis/urls/prettyprint/prettyprint.factor | 7 +++++-- basis/urls/urls-tests.factor | 4 +++- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/basis/urls/prettyprint/prettyprint.factor b/basis/urls/prettyprint/prettyprint.factor index 59fb79e8d3..35e428c8fa 100644 --- a/basis/urls/prettyprint/prettyprint.factor +++ b/basis/urls/prettyprint/prettyprint.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel present prettyprint.custom prettyprint.backend urls ; +USING: kernel present prettyprint.custom prettyprint.sections +prettyprint.backend urls ; IN: urls.prettyprint -M: url pprint* dup present "URL\" " "\"" pprint-string ; +M: url pprint* + \ URL" record-vocab + dup present "URL\" " "\"" pprint-string ; diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor index 74eea9506c..f45ad6449e 100644 --- a/basis/urls/urls-tests.factor +++ b/basis/urls/urls-tests.factor @@ -1,5 +1,5 @@ IN: urls.tests -USING: urls urls.private tools.test +USING: urls urls.private tools.test prettyprint arrays kernel assocs present accessors ; CONSTANT: urls @@ -227,3 +227,5 @@ urls [ [ "http://localhost/?foo=bar" >url ] unit-test [ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test + +[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test \ No newline at end of file From 68728d1cc4d82d688ff7c46990efd96b27b90c84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 20:44:34 -0500 Subject: [PATCH 67/73] Fix prettyprint of CONSTANT: and ALIAS: --- basis/see/see-tests.factor | 11 +++++++++++ basis/see/see.factor | 12 ++++++++++-- core/words/alias/alias.factor | 7 ++++--- core/words/constant/constant-tests.factor | 14 ++++++++++++++ core/words/constant/constant.factor | 8 ++++++-- 5 files changed, 45 insertions(+), 7 deletions(-) create mode 100644 basis/see/see-tests.factor create mode 100644 core/words/constant/constant-tests.factor diff --git a/basis/see/see-tests.factor b/basis/see/see-tests.factor new file mode 100644 index 0000000000..3f11ec987e --- /dev/null +++ b/basis/see/see-tests.factor @@ -0,0 +1,11 @@ +IN: see.tests +USING: see tools.test io.streams.string math ; + +CONSTANT: test-const 10 +[ "IN: see.tests\nCONSTANT: test-const 10 inline\n" ] +[ [ \ test-const see ] with-string-writer ] unit-test + +ALIAS: test-alias + + +[ "USING: math ;\nIN: see.tests\nALIAS: test-alias + inline\n" ] +[ [ \ test-alias see ] with-string-writer ] unit-test diff --git a/basis/see/see.factor b/basis/see/see.factor index 32f49499db..9fc14ff581 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -7,7 +7,7 @@ definitions effects generic generic.standard io io.pathnames io.streams.string io.styles kernel make namespaces prettyprint prettyprint.backend prettyprint.config prettyprint.custom prettyprint.sections sequences sets sorting strings summary -words words.symbol ; +words words.symbol words.constant words.alias ; IN: see GENERIC: synopsis* ( defspec -- ) @@ -29,8 +29,16 @@ GENERIC: see* ( defspec -- ) : comment. ( text -- ) H{ { font-style italic } } styled-text ; +GENERIC: print-stack-effect? ( word -- ? ) + +M: parsing-word print-stack-effect? drop f ; +M: symbol print-stack-effect? drop f ; +M: constant print-stack-effect? drop f ; +M: alias print-stack-effect? drop f ; +M: word print-stack-effect? drop t ; + : stack-effect. ( word -- ) - [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and + [ print-stack-effect? ] [ stack-effect ] bi and [ effect>string comment. ] when* ; > first stack-effect ; +M: alias definer drop \ ALIAS: f ; + +M: alias definition def>> first 1quotation ; \ No newline at end of file diff --git a/core/words/constant/constant-tests.factor b/core/words/constant/constant-tests.factor new file mode 100644 index 0000000000..2755039af6 --- /dev/null +++ b/core/words/constant/constant-tests.factor @@ -0,0 +1,14 @@ +IN: words.constant.tests +USING: tools.test math ; + +CONSTANT: a + + +[ + ] [ a ] unit-test + +CONSTANT: b \ + + +[ \ + ] [ b ] unit-test + +CONSTANT: c { 1 2 3 } + +[ { 1 2 3 } ] [ c ] unit-test diff --git a/core/words/constant/constant.factor b/core/words/constant/constant.factor index 43b7f37599..00302df98a 100644 --- a/core/words/constant/constant.factor +++ b/core/words/constant/constant.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences words ; +USING: accessors kernel sequences words definitions quotations ; IN: words.constant PREDICATE: constant < word ( obj -- ? ) @@ -8,3 +8,7 @@ PREDICATE: constant < word ( obj -- ? ) : define-constant ( word value -- ) [ ] curry (( -- value )) define-inline ; + +M: constant definer drop \ CONSTANT: f ; + +M: constant definition def>> first literalize 1quotation ; \ No newline at end of file From 880f4097adf08767d96f014cd2476fa835e54b38 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 20:50:45 -0500 Subject: [PATCH 68/73] Clear button in search field is now positioned correctly --- basis/ui/gadgets/search-tables/search-tables-tests.factor | 3 +++ basis/ui/gadgets/search-tables/search-tables.factor | 1 + 2 files changed, 4 insertions(+) create mode 100644 basis/ui/gadgets/search-tables/search-tables-tests.factor diff --git a/basis/ui/gadgets/search-tables/search-tables-tests.factor b/basis/ui/gadgets/search-tables/search-tables-tests.factor new file mode 100644 index 0000000000..5a627286f9 --- /dev/null +++ b/basis/ui/gadgets/search-tables/search-tables-tests.factor @@ -0,0 +1,3 @@ +IN: ui.gadgets.search-tables.tests +USING: ui.gadgets.search-tables sequences tools.test ; +[ [ second ] ] must-infer diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor index 4a2983bfe0..17570a8714 100644 --- a/basis/ui/gadgets/search-tables/search-tables.factor +++ b/basis/ui/gadgets/search-tables/search-tables.factor @@ -28,6 +28,7 @@ TUPLE: search-field < track field ; : ( model -- gadget ) horizontal search-field new-track + 0 >>fill { 5 5 } >>gap +baseline+ >>align swap 10 >>min-cols >>field From 687e9f90fe70c5e0491995fa911d797b9eaf07d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:16:48 -0500 Subject: [PATCH 69/73] Move models.history to extra --- basis/models/models-docs.factor | 1 - {basis => extra}/models/history/history-docs.factor | 0 {basis => extra}/models/history/history-tests.factor | 0 {basis => extra}/models/history/history.factor | 0 {basis => extra}/models/history/summary.txt | 0 5 files changed, 1 deletion(-) rename {basis => extra}/models/history/history-docs.factor (100%) rename {basis => extra}/models/history/history-tests.factor (100%) rename {basis => extra}/models/history/history.factor (100%) rename {basis => extra}/models/history/summary.txt (100%) diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 2b90bdb0d5..8f40a8adbe 100644 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -133,7 +133,6 @@ $nl { $subsection "models-impl" } { $subsection "models.arrow" } { $subsection "models.product" } -{ $subsection "models-history" } { $subsection "models-range" } { $subsection "models-delay" } ; diff --git a/basis/models/history/history-docs.factor b/extra/models/history/history-docs.factor similarity index 100% rename from basis/models/history/history-docs.factor rename to extra/models/history/history-docs.factor diff --git a/basis/models/history/history-tests.factor b/extra/models/history/history-tests.factor similarity index 100% rename from basis/models/history/history-tests.factor rename to extra/models/history/history-tests.factor diff --git a/basis/models/history/history.factor b/extra/models/history/history.factor similarity index 100% rename from basis/models/history/history.factor rename to extra/models/history/history.factor diff --git a/basis/models/history/summary.txt b/extra/models/history/summary.txt similarity index 100% rename from basis/models/history/summary.txt rename to extra/models/history/summary.txt From 8bf5fde791b992a73761614e6024982a804317df Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:18:25 -0500 Subject: [PATCH 70/73] Rename scroll word to set-scroll-position and make it public --- .../gadgets/scrollers/scrollers-docs.factor | 8 +++--- .../gadgets/scrollers/scrollers-tests.factor | 2 +- basis/ui/gadgets/scrollers/scrollers.factor | 25 ++++++++++--------- basis/ui/gadgets/viewports/viewports.factor | 4 +-- 4 files changed, 20 insertions(+), 19 deletions(-) diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor index 8e0131ec31..92831bea00 100644 --- a/basis/ui/gadgets/scrollers/scrollers-docs.factor +++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor @@ -11,11 +11,11 @@ HELP: find-scroller { $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } } { $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ; -HELP: scroller-value +HELP: scroll-position { $values { "scroller" scroller } { "loc" "a pair of integers" } } { $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; -{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words +{ scroll-position scroll scroll>bottom scroll>top scroll>rect } related-words HELP: { $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } } @@ -48,8 +48,8 @@ ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets" { $subsection scroller } { $subsection } "Getting and setting the scroll position:" -{ $subsection scroller-value } -{ $subsection scroll } +{ $subsection scroll-position } +{ $subsection set-scroll-position } "Writing scrolling-aware gadgets:" { $subsection scroll>bottom } { $subsection scroll>top } diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index d4cdc95daf..cf63d616be 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -74,7 +74,7 @@ dup layout drop "g2" get scroll>gadget "s" get layout - "s" get scroller-value + "s" get scroll-position ] map [ { 0 0 } = ] all? ] unit-test diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor index a526cc618b..0852a6fe5d 100644 --- a/basis/ui/gadgets/scrollers/scrollers.factor +++ b/basis/ui/gadgets/scrollers/scrollers.factor @@ -29,6 +29,13 @@ M: gadget viewport-column-header drop f ; : scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ; +: set-scroll-position ( value scroller -- ) + [ + viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi + 4array flip + ] keep + 2dup control-value = [ 2drop ] [ set-control-value ] if ; + > [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi - 4array flip - ] keep - 2dup control-value = [ 2drop ] [ set-control-value ] if ; - : (scroll>rect) ( rect scroller -- ) { - [ scroller-value vneg offset-rect ] + [ scroll-position vneg offset-rect ] [ viewport>> dim>> rect-min ] [ viewport>> loc>> offset-rect ] [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ] - [ scroller-value v+ ] - [ scroll ] + [ scroll-position v+ ] + [ set-scroll-position ] } cleave ; : relative-scroll-rect ( rect gadget scroller -- newrect ) @@ -72,7 +72,7 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ; 2&& ; : (update-scroller) ( scroller -- ) - [ scroller-value ] keep scroll ; + [ scroll-position ] keep set-scroll-position ; : (scroll>gadget) ( gadget scroller -- ) 2dup swap child? [ @@ -82,7 +82,8 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ; ] [ f >>follows (update-scroller) drop ] if ; : (scroll>bottom) ( scroller -- ) - [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ; + [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep + set-scroll-position ; GENERIC: update-scroller ( scroller follows -- ) diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor index c14c7f01fb..b154ef2322 100644 --- a/basis/ui/gadgets/viewports/viewports.factor +++ b/basis/ui/gadgets/viewports/viewports.factor @@ -23,7 +23,7 @@ M: viewport layout* M: viewport focusable-child* gadget-child ; -: scroller-value ( scroller -- loc ) +: scroll-position ( scroller -- loc ) model>> range-value [ >integer ] map ; M: viewport model-changed @@ -31,7 +31,7 @@ M: viewport model-changed [ relayout-1 ] [ [ gadget-child ] - [ scroller-value vneg ] + [ scroll-position vneg ] [ constraint>> ] tri v* >>loc drop ] bi ; From 78013c2bdffc9f579bbe1d8c137c265f32b7e77e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:19:18 -0500 Subject: [PATCH 71/73] Rename scroll word to set-scroll-position and make it public --- basis/ui/gadgets/scrollers/scrollers-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor index 92831bea00..011afa5c97 100644 --- a/basis/ui/gadgets/scrollers/scrollers-docs.factor +++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor @@ -15,7 +15,7 @@ HELP: scroll-position { $values { "scroller" scroller } { "loc" "a pair of integers" } } { $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; -{ scroll-position scroll scroll>bottom scroll>top scroll>rect } related-words +{ scroll-position set-scroll-position scroll>bottom scroll>top scroll>rect } related-words HELP: { $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } } @@ -23,7 +23,7 @@ HELP: { } related-words -HELP: scroll +HELP: set-scroll-position { $values { "scroller" scroller } { "value" "a pair of integers" } } { $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ; From 88bbb47bfa31afb37513628286b4146198da93f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:19:35 -0500 Subject: [PATCH 72/73] Browser tool now saves scroll bar position in history --- basis/ui/tools/browser/browser.factor | 41 ++++++++++++------- basis/ui/tools/browser/history/authors.txt | 1 + .../browser/history/history-tests.factor | 36 ++++++++++++++++ basis/ui/tools/browser/history/history.factor | 32 +++++++++++++++ 4 files changed, 95 insertions(+), 15 deletions(-) create mode 100644 basis/ui/tools/browser/history/authors.txt create mode 100644 basis/ui/tools/browser/history/history-tests.factor create mode 100644 basis/ui/tools/browser/history/history.factor diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index e242b743f8..0c6e1fe05a 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -1,23 +1,33 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: debugger help help.topics help.crossref help.home kernel -models compiler.units assocs words vocabs accessors fry -combinators.short-circuit namespaces sequences models -models.history help.apropos combinators ui.commands ui.gadgets -ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks -ui.gestures ui.gadgets.buttons ui.gadgets.packs -ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar -ui.gadgets.glass ui.gadgets.borders ui.tools.common -ui.tools.browser.popups ui ; +USING: debugger help help.topics help.crossref help.home kernel models +compiler.units assocs words vocabs accessors fry arrays +combinators.short-circuit namespaces sequences models help.apropos +combinators ui ui.commands ui.gadgets ui.gadgets.panes +ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons +ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels +ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports +ui.tools.common ui.tools.browser.popups ui.tools.browser.history ; IN: ui.tools.browser -TUPLE: browser-gadget < tool pane scroller search-field popup ; +TUPLE: browser-gadget < tool history pane scroller search-field popup ; { 650 400 } browser-gadget set-tool-dim +M: browser-gadget history-value + [ control-value ] [ scroller>> scroll-position ] + bi 2array ; + +M: browser-gadget set-history-value + [ first2 ] dip + [ set-control-value ] [ scroller>> set-scroll-position ] + bi-curry bi* ; + : show-help ( link browser-gadget -- ) - [ >link ] [ model>> ] bi* - [ [ add-recent ] [ add-history ] bi* ] [ set-model ] 2bi ; + [ >link ] dip + [ [ add-recent ] [ history>> add-history ] bi* ] + [ model>> set-model ] + 2bi ; : ( browser-gadget -- gadget ) model>> [ '[ _ print-topic ] try ] ; @@ -41,7 +51,8 @@ TUPLE: browser-gadget < tool pane scroller search-field popup ; : ( link -- gadget ) vertical browser-gadget new-track 1 >>fill - swap >link >>model + swap >link >>model + dup >>history dup >>search-field dup { 3 3 } { 1 0 } >>fill f track-add dup >>pane @@ -93,9 +104,9 @@ M: browser-gadget focusable-child* search-field>> ; \ show-browser H{ { +nullary+ t } } define-command -: com-back ( browser -- ) model>> go-back ; +: com-back ( browser -- ) history>> go-back ; -: com-forward ( browser -- ) model>> go-forward ; +: com-forward ( browser -- ) history>> go-forward ; : com-home ( browser -- ) "help.home" swap show-help ; diff --git a/basis/ui/tools/browser/history/authors.txt b/basis/ui/tools/browser/history/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/tools/browser/history/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/tools/browser/history/history-tests.factor b/basis/ui/tools/browser/history/history-tests.factor new file mode 100644 index 0000000000..20b16f450a --- /dev/null +++ b/basis/ui/tools/browser/history/history-tests.factor @@ -0,0 +1,36 @@ +USING: namespaces ui.tools.browser.history sequences tools.test ; +IN: ui.tools.browser.history.tests + +f "history" set + +"history" get add-history + +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get add-history +"history" get 3 >>value drop + +[ t ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get add-history +"history" get 4 >>value drop + +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + +"history" get go-back + +[ 3 ] [ "history" get value>> ] unit-test + +[ t ] [ "history" get back>> empty? ] unit-test +[ f ] [ "history" get forward>> empty? ] unit-test + +"history" get go-forward + +[ 4 ] [ "history" get value>> ] unit-test + +[ f ] [ "history" get back>> empty? ] unit-test +[ t ] [ "history" get forward>> empty? ] unit-test + diff --git a/basis/ui/tools/browser/history/history.factor b/basis/ui/tools/browser/history/history.factor new file mode 100644 index 0000000000..f80189c783 --- /dev/null +++ b/basis/ui/tools/browser/history/history.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences locals ; +IN: ui.tools.browser.history + +TUPLE: history owner back forward ; + +: ( owner -- history ) + V{ } clone V{ } clone history boa ; + +GENERIC: history-value ( object -- value ) + +GENERIC: set-history-value ( value object -- ) + +: (add-history) ( history to -- ) + swap owner>> history-value dup [ swap push ] [ 2drop ] if ; + +:: go-back/forward ( history to from -- ) + from empty? [ + history to (add-history) + from pop history owner>> set-history-value + ] unless ; + +: go-back ( history -- ) + dup [ forward>> ] [ back>> ] bi go-back/forward ; + +: go-forward ( history -- ) + dup [ back>> ] [ forward>> ] bi go-back/forward ; + +: add-history ( history -- ) + dup forward>> delete-all + dup back>> (add-history) ; \ No newline at end of file From cb6030778f78d75ec1bcb2a28873cd9ab05bbc2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 5 Apr 2009 23:38:47 -0500 Subject: [PATCH 73/73] Fix ui.gadgets.scrollers unit tests --- basis/ui/gadgets/scrollers/scrollers-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor index cf63d616be..22df1f328b 100644 --- a/basis/ui/gadgets/scrollers/scrollers-tests.factor +++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor @@ -45,13 +45,13 @@ IN: ui.gadgets.scrollers.tests [ { 100 100 } ] [ "s" get viewport>> gadget-child pref-dim ] unit-test - [ ] [ { 0 0 } "s" get scroll ] unit-test + [ ] [ { 0 0 } "s" get set-scroll-position ] unit-test [ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test [ { 100 100 } ] [ "s" get model>> range-max-value ] unit-test - [ ] [ { 10 20 } "s" get scroll ] unit-test + [ ] [ { 10 20 } "s" get set-scroll-position ] unit-test [ { 10 20 } ] [ "s" get model>> range-value ] unit-test