From c3b63821b9dad9e025a081496045215bda92c622 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 29 Apr 2009 14:58:55 -0500 Subject: [PATCH 01/58] literal syntax for rects --- basis/math/rectangles/rectangles-tests.factor | 28 +++++++++---------- basis/math/rectangles/rectangles.factor | 10 +++++-- 2 files changed, 22 insertions(+), 16 deletions(-) diff --git a/basis/math/rectangles/rectangles-tests.factor b/basis/math/rectangles/rectangles-tests.factor index ca722859d2..7959d98f92 100644 --- a/basis/math/rectangles/rectangles-tests.factor +++ b/basis/math/rectangles/rectangles-tests.factor @@ -1,42 +1,42 @@ USING: tools.test math.rectangles ; IN: math.rectangles.tests -[ T{ rect f { 10 10 } { 20 20 } } ] +[ RECT: { 10 10 } { 20 20 } ] [ - T{ rect f { 10 10 } { 50 50 } } - T{ rect f { -10 -10 } { 40 40 } } + RECT: { 10 10 } { 50 50 } + RECT: { -10 -10 } { 40 40 } rect-intersect ] unit-test -[ T{ rect f { 200 200 } { 0 0 } } ] +[ RECT: { 200 200 } { 0 0 } ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 200 200 } { 40 40 } } + RECT: { 100 100 } { 50 50 } + RECT: { 200 200 } { 40 40 } rect-intersect ] unit-test [ f ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 200 200 } { 40 40 } } + RECT: { 100 100 } { 50 50 } + RECT: { 200 200 } { 40 40 } contains-rect? ] unit-test [ t ] [ - T{ rect f { 100 100 } { 50 50 } } - T{ rect f { 120 120 } { 40 40 } } + RECT: { 100 100 } { 50 50 } + RECT: { 120 120 } { 40 40 } contains-rect? ] unit-test [ f ] [ - T{ rect f { 1000 100 } { 50 50 } } - T{ rect f { 120 120 } { 40 40 } } + RECT: { 1000 100 } { 50 50 } + RECT: { 120 120 } { 40 40 } contains-rect? ] unit-test -[ T{ rect f { 10 20 } { 20 20 } } ] [ +[ RECT: { 10 20 } { 20 20 } ] [ { { 20 20 } { 10 40 } { 30 30 } } rect-containing -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index 1d9c91328f..90174d144e 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -1,12 +1,18 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays sequences math math.vectors accessors ; +USING: kernel arrays sequences math math.vectors accessors +parser prettyprint.custom prettyprint.backend ; IN: math.rectangles TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; : ( loc dim -- rect ) rect boa ; inline +SYNTAX: RECT: scan-object scan-object parsed ; + +M: rect pprint* + \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; + : ( -- rect ) rect new ; inline : point>rect ( loc -- rect ) { 0 0 } ; inline @@ -55,4 +61,4 @@ M: rect contains-point? : set-rect-bounds ( rect1 rect -- ) [ [ loc>> ] dip (>>loc) ] [ [ dim>> ] dip (>>dim) ] - 2bi ; inline \ No newline at end of file + 2bi ; inline From 7857c0c939bcb16d82506a09de0f9db737ea201c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 29 Apr 2009 14:59:54 -0500 Subject: [PATCH 02/58] typo in delegate docs --- basis/delegate/delegate-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 42b727852e..42e770aa75 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -24,7 +24,7 @@ HELP: CONSULT: HELP: SLOT-PROTOCOL: { $syntax "SLOT-PROTOCOL: protocol-name slots... ;" } -{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ; +{ $description "Defines a protocol consisting of reader and writer words for the listed slot names." } ; { define-protocol POSTPONE: PROTOCOL: } related-words From a18c5816e036fabdb2a116b2038c44096ae6cffb Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Thu, 30 Apr 2009 08:29:49 -0500 Subject: [PATCH 03/58] refactoring cocoa.dialogs for directories --- basis/cocoa/dialogs/dialogs.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/basis/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor index 84a1ad46a3..7761286127 100644 --- a/basis/cocoa/dialogs/dialogs.factor +++ b/basis/cocoa/dialogs/dialogs.factor @@ -12,6 +12,9 @@ IN: cocoa.dialogs dup 1 -> setResolvesAliases: dup 1 -> setAllowsMultipleSelection: ; +: ( -- panel ) + dup 1 -> setCanChooseDirectories: ; + : ( -- panel ) NSSavePanel -> savePanel dup 1 -> setCanChooseFiles: @@ -21,10 +24,12 @@ IN: cocoa.dialogs CONSTANT: NSOKButton 1 CONSTANT: NSCancelButton 0 -: open-panel ( -- paths ) - +: (open-panel) ( panel -- paths ) dup -> runModal NSOKButton = [ -> filenames CF>string-array ] [ drop f ] if ; + +: open-panel ( -- paths ) (open-panel) ; +: open-dir-panel ( -- paths ) (open-panel) ; : split-path ( path -- dir file ) "/" split1-last [ ] bi@ ; From 5038cb3ba61b8fc6555000a567411113839c74d2 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Thu, 30 Apr 2009 08:30:45 -0500 Subject: [PATCH 04/58] added run-desc in io.launcher --- basis/io/launcher/launcher.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index f5809223fc..838c09c657 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -3,9 +3,9 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors environment -io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.ports debugger prettyprint summary -calendar ; +io io.encodings.ascii io.backend io.timeouts io.pipes +io.pipes.private io.encodings io.streams.duplex io.ports +debugger prettyprint summary calendar ; IN: io.launcher TUPLE: process < identity-tuple @@ -265,3 +265,5 @@ M: object run-pipeline-element { [ os winnt? ] [ "io.launcher.windows.nt" require ] } [ ] } cond + +: run-desc ( desc -- result ) ascii f swap stream-read-until drop ; From 76d375b56b7003aa8197e7740191214d7f3c7b7f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Apr 2009 20:31:33 -0500 Subject: [PATCH 05/58] OS-independent pixel formats abstraction --- basis/ui/pixel-formats/pixel-formats.factor | 58 +++++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100644 basis/ui/pixel-formats/pixel-formats.factor diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor new file mode 100644 index 0000000000..09450f2c72 --- /dev/null +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -0,0 +1,58 @@ +USING: destructors math ui.backend ; +IN: ui.pixel-formats + +SINGLETONS: + double-buffered + stereo + offscreen + fullscreen + windowed + accelerated + software-rendered + robust + backing-store + multisampled + supersampled + sample-alpha + color-float ; + +TUPLE: pixel-format-attribute { value integer } ; + +TUPLE: color-bits < pixel-format-attribute ; +TUPLE: red-bits < pixel-format-attribute ; +TUPLE: green-bits < pixel-format-attribute ; +TUPLE: blue-bits < pixel-format-attribute ; +TUPLE: alpha-bits < pixel-format-attribute ; + +TUPLE: accum-bits < pixel-format-attribute ; +TUPLE: accum-red-bits < pixel-format-attribute ; +TUPLE: accum-green-bits < pixel-format-attribute ; +TUPLE: accum-blue-bits < pixel-format-attribute ; +TUPLE: accum-alpha-bits < pixel-format-attribute ; + +TUPLE: depth-bits < pixel-format-attribute ; + +TUPLE: stencil-bits < pixel-format-attribute ; + +TUPLE: aux-buffers < pixel-format-attribute ; + +TUPLE: buffer-level < pixel-format-attribute ; + +TUPLE: sample-buffers < pixel-format-attribute ; +TUPLE: samples < pixel-format-attribute ; + +HOOK: (make-pixel-format) ui-backend ( attributes -- pixel-format-handle ) +HOOK: (free-pixel-format) ui-backend ( pixel-format-handle -- ) +HOOK: (pixel-format-attribute) ui-backend ( pixel-format-handle attribute-name -- value ) + +TUPLE: pixel-format { handle read-only } ; + +: ( attributes -- pixel-format ) + (make-pixel-format) pixel-format boa ; + +M: pixel-format dispose + [ [ (free-pixel-format) ] when* f ] change-handle drop ; + +: pixel-format-attribute ( pixel-format attribute-name -- value ) + [ handle>> ] dip (pixel-format-attribute) ; + From 3edd57aaa4e37ddc917a3301d03e106e05ac168a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Apr 2009 20:38:18 -0500 Subject: [PATCH 06/58] eliminate windows.opengl32 dependency from opengl.gl.windows so we can use opengl.gl.extensions to define wgl extensions --- basis/opengl/gl/windows/windows.factor | 7 ++++++- basis/windows/opengl32/opengl32.factor | 5 +++-- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/basis/opengl/gl/windows/windows.factor b/basis/opengl/gl/windows/windows.factor index 8f48f60d3c..c8a179edf5 100644 --- a/basis/opengl/gl/windows/windows.factor +++ b/basis/opengl/gl/windows/windows.factor @@ -1,6 +1,11 @@ -USING: kernel windows.opengl32 ; +USING: alien.syntax kernel windows.types ; IN: opengl.gl.windows +LIBRARY: gl + +FUNCTION: HGLRC wglGetCurrentContext ( ) ; +FUNCTION: void* wglGetProcAddress ( char* name ) ; + : gl-function-context ( -- context ) wglGetCurrentContext ; inline : gl-function-address ( name -- address ) wglGetProcAddress ; inline : gl-function-calling-convention ( -- str ) "stdcall" ; inline diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor index d0b396eba2..f63a4a956a 100755 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax parser namespaces kernel -math math.bitwise windows.types windows.types init assocs -sequences libc ; +math math.bitwise windows.types init assocs +sequences libc opengl.gl ; IN: windows.opengl32 ! PIXELFORMATDESCRIPTOR flags @@ -100,5 +100,6 @@ LIBRARY: gl FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ; FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ; FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ; + FUNCTION: HGLRC wglGetCurrentContext ( ) ; FUNCTION: void* wglGetProcAddress ( char* name ) ; From 9149f375d1b14c84f99f92b3d4d8f7fd5329dd9b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Apr 2009 21:35:50 -0500 Subject: [PATCH 07/58] WGL_ARB_pixel_format extension binding --- basis/windows/opengl32/opengl32.factor | 112 ++++++++++++++++++++++++- 1 file changed, 109 insertions(+), 3 deletions(-) diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor index f63a4a956a..d5e8fe9a66 100755 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax parser namespaces kernel math math.bitwise windows.types init assocs -sequences libc opengl.gl ; +sequences libc opengl.gl opengl.gl.extensions opengl.gl.windows ; IN: windows.opengl32 ! PIXELFORMATDESCRIPTOR flags @@ -101,5 +101,111 @@ FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ; FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ; FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ; -FUNCTION: HGLRC wglGetCurrentContext ( ) ; -FUNCTION: void* wglGetProcAddress ( char* name ) ; +! WGL_ARB_extensions_string extension + +GL-FUNCTION: char* wglGetExtensionsStringARB ( HDC hDC ) ; + +! WGL_ARB_pixel_format extension + +CONSTANT: WGL_NUMBER_PIXEL_FORMATS_ARB HEX: 2000 +CONSTANT: WGL_DRAW_TO_WINDOW_ARB HEX: 2001 +CONSTANT: WGL_DRAW_TO_BITMAP_ARB HEX: 2002 +CONSTANT: WGL_ACCELERATION_ARB HEX: 2003 +CONSTANT: WGL_NEED_PALETTE_ARB HEX: 2004 +CONSTANT: WGL_NEED_SYSTEM_PALETTE_ARB HEX: 2005 +CONSTANT: WGL_SWAP_LAYER_BUFFERS_ARB HEX: 2006 +CONSTANT: WGL_SWAP_METHOD_ARB HEX: 2007 +CONSTANT: WGL_NUMBER_OVERLAYS_ARB HEX: 2008 +CONSTANT: WGL_NUMBER_UNDERLAYS_ARB HEX: 2009 +CONSTANT: WGL_TRANSPARENT_ARB HEX: 200A +CONSTANT: WGL_TRANSPARENT_RED_VALUE_ARB HEX: 2037 +CONSTANT: WGL_TRANSPARENT_GREEN_VALUE_ARB HEX: 2038 +CONSTANT: WGL_TRANSPARENT_BLUE_VALUE_ARB HEX: 2039 +CONSTANT: WGL_TRANSPARENT_ALPHA_VALUE_ARB HEX: 203A +CONSTANT: WGL_TRANSPARENT_INDEX_VALUE_ARB HEX: 203B +CONSTANT: WGL_SHARE_DEPTH_ARB HEX: 200C +CONSTANT: WGL_SHARE_STENCIL_ARB HEX: 200D +CONSTANT: WGL_SHARE_ACCUM_ARB HEX: 200E +CONSTANT: WGL_SUPPORT_GDI_ARB HEX: 200F +CONSTANT: WGL_SUPPORT_OPENGL_ARB HEX: 2010 +CONSTANT: WGL_DOUBLE_BUFFER_ARB HEX: 2011 +CONSTANT: WGL_STEREO_ARB HEX: 2012 +CONSTANT: WGL_PIXEL_TYPE_ARB HEX: 2013 +CONSTANT: WGL_COLOR_BITS_ARB HEX: 2014 +CONSTANT: WGL_RED_BITS_ARB HEX: 2015 +CONSTANT: WGL_RED_SHIFT_ARB HEX: 2016 +CONSTANT: WGL_GREEN_BITS_ARB HEX: 2017 +CONSTANT: WGL_GREEN_SHIFT_ARB HEX: 2018 +CONSTANT: WGL_BLUE_BITS_ARB HEX: 2019 +CONSTANT: WGL_BLUE_SHIFT_ARB HEX: 201A +CONSTANT: WGL_ALPHA_BITS_ARB HEX: 201B +CONSTANT: WGL_ALPHA_SHIFT_ARB HEX: 201C +CONSTANT: WGL_ACCUM_BITS_ARB HEX: 201D +CONSTANT: WGL_ACCUM_RED_BITS_ARB HEX: 201E +CONSTANT: WGL_ACCUM_GREEN_BITS_ARB HEX: 201F +CONSTANT: WGL_ACCUM_BLUE_BITS_ARB HEX: 2020 +CONSTANT: WGL_ACCUM_ALPHA_BITS_ARB HEX: 2021 +CONSTANT: WGL_DEPTH_BITS_ARB HEX: 2022 +CONSTANT: WGL_STENCIL_BITS_ARB HEX: 2023 +CONSTANT: WGL_AUX_BUFFERS_ARB HEX: 2024 + +CONSTANT: WGL_NO_ACCELERATION_ARB HEX: 2025 +CONSTANT: WGL_GENERIC_ACCELERATION_ARB HEX: 2026 +CONSTANT: WGL_FULL_ACCELERATION_ARB HEX: 2027 + +CONSTANT: WGL_SWAP_EXCHANGE_ARB HEX: 2028 +CONSTANT: WGL_SWAP_COPY_ARB HEX: 2029 +CONSTANT: WGL_SWAP_UNDEFINED_ARB HEX: 202A + +CONSTANT: WGL_TYPE_RGBA_ARB HEX: 202B +CONSTANT: WGL_TYPE_COLORINDEX_ARB HEX: 202C + +GL-FUNCTION: BOOL wglGetPixelFormatAttribivARB ( + HDC hdc, + int iPixelFormat, + int iLayerPlane, + UINT nAttributes, + int* piAttributes, + int* piValues + ) ; + +GL-FUNCTION: BOOL wglGetPixelFormatAttribfvARB ( + HDC hdc, + int iPixelFormat, + int iLayerPlane, + UINT nAttributes, + int* piAttributes, + FLOAT* pfValues + ) ; + +GL-FUNCTION: BOOL wglChoosePixelFormatARB ( + HDC hdc, + int* piAttribIList, + FLOAT* pfAttribFList, + UINT nMaxFormats, + int* piFormats, + UINT* nNumFormats + ) ; + +! WGL_ARB_multisample extension + +CONSTANT: WGL_SAMPLE_BUFFERS_ARB HEX: 2041 +CONSTANT: WGL_SAMPLES_ARB HEX: 2042 + +! WGL_ARB_pixel_format_float extension + +CONSTANT: WGL_TYPE_RGBA_FLOAT_ARB HEX: 21A0 + +! wgl extensions querying + +: has-wglGetExtensionsStringARB? ( -- ? ) + "wglGetExtensionsStringARB" wglGetProcAddress >boolean ; + +: wgl-extensions ( hdc -- extensions ) + has-wglGetExtensionsStringARB? [ wglGetExtensionsStringARB " " split ] [ drop { } ] if ; + +: has-wgl-extensions? ( hdc extensions -- ? ) + swap wgl-extensions [ member? ] curry all? ; + +: has-wgl-pixel-format-extension? ( hdc -- ? ) + { "WGL_ARB_pixel_format" } has-wgl-extensions? ; From 8a4c6a30f90886f4b6a02401369361cd122791b4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Apr 2009 22:28:45 -0500 Subject: [PATCH 08/58] multisample and float extensions for GLX --- basis/x11/glx/glx.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index dc6157b87f..b459b55f46 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -84,6 +84,14 @@ X-FUNCTION: void* glXGetProcAddress ( char* procname ) ; ! GLX_ARB_get_proc_address extension X-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; +! GLX_ARB_multisample +CONSTANT: GLX_SAMPLE_BUFFERS 100000 +CONSTANT: GLX_SAMPLES 100001 + +! GLX_ARB_fbconfig_float +CONSTANT: GLX_RGBA_FLOAT_TYPE HEX: 20B9 +CONSTANT: GLX_RGBA_FLOAT_BIT HEX: 0004 + ! GLX Events ! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks) From b6074b95fafe484484ffff8e42587c7b2f1e72b2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Apr 2009 22:35:15 -0500 Subject: [PATCH 09/58] get rid of variable-based pixel format crap in cocoa.views --- basis/cocoa/views/views.factor | 25 ++++--------------------- 1 file changed, 4 insertions(+), 21 deletions(-) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index 3c60a6a7c1..69d0f98618 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -42,31 +42,14 @@ CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96 CONSTANT: NSOpenGLPFAVirtualScreenCount 128 CONSTANT: NSOpenGLCPSwapInterval 222 - - -: with-software-renderer ( quot -- ) - [ t software-renderer? ] dip with-variable ; inline - -: with-multisample ( quot -- ) - [ t multisample? ] dip with-variable ; inline - : ( attributes -- pixelfmt ) NSOpenGLPixelFormat -> alloc swap [ % NSOpenGLPFADepthSize , 16 , - software-renderer? get [ - NSOpenGLPFARendererID , kCGLRendererGenericFloatID , - ] when - multisample? get [ - NSOpenGLPFASupersample , - NSOpenGLPFASampleBuffers , 1 , - NSOpenGLPFASamples , 8 , - ] when + ! NSOpenGLPFARendererID , kCGLRendererGenericFloatID , + ! NSOpenGLPFASupersample , + ! NSOpenGLPFASampleBuffers , 1 , + ! NSOpenGLPFASamples , 8 , 0 , ] int-array{ } make -> initWithAttributes: From 87daa532a6f36ca1ff225bc5aac3f32f8e4cf39a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 30 Apr 2009 22:48:01 -0500 Subject: [PATCH 10/58] move literals vocab to basis --- {extra => basis}/literals/authors.txt | 0 {extra => basis}/literals/literals-docs.factor | 0 {extra => basis}/literals/literals-tests.factor | 0 {extra => basis}/literals/literals.factor | 0 {extra => basis}/literals/summary.txt | 0 {extra => basis}/literals/tags.txt | 0 6 files changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/literals/authors.txt (100%) rename {extra => basis}/literals/literals-docs.factor (100%) rename {extra => basis}/literals/literals-tests.factor (100%) rename {extra => basis}/literals/literals.factor (100%) rename {extra => basis}/literals/summary.txt (100%) rename {extra => basis}/literals/tags.txt (100%) diff --git a/extra/literals/authors.txt b/basis/literals/authors.txt similarity index 100% rename from extra/literals/authors.txt rename to basis/literals/authors.txt diff --git a/extra/literals/literals-docs.factor b/basis/literals/literals-docs.factor similarity index 100% rename from extra/literals/literals-docs.factor rename to basis/literals/literals-docs.factor diff --git a/extra/literals/literals-tests.factor b/basis/literals/literals-tests.factor similarity index 100% rename from extra/literals/literals-tests.factor rename to basis/literals/literals-tests.factor diff --git a/extra/literals/literals.factor b/basis/literals/literals.factor similarity index 100% rename from extra/literals/literals.factor rename to basis/literals/literals.factor diff --git a/extra/literals/summary.txt b/basis/literals/summary.txt similarity index 100% rename from extra/literals/summary.txt rename to basis/literals/summary.txt diff --git a/extra/literals/tags.txt b/basis/literals/tags.txt similarity index 100% rename from extra/literals/tags.txt rename to basis/literals/tags.txt From ba8abd6cad39035ebff3f708af07823b54b7cb30 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 1 May 2009 09:09:38 -0500 Subject: [PATCH 11/58] cocoa backend support for ui.pixel-formats; world-pixel-format-attributes generic --- basis/cocoa/views/views.factor | 20 ++---- basis/ui/backend/cocoa/cocoa.factor | 73 ++++++++++++++++++--- basis/ui/backend/cocoa/views/views.factor | 4 +- basis/ui/gadgets/worlds/worlds.factor | 11 +++- basis/ui/pixel-formats/pixel-formats.factor | 2 +- 5 files changed, 80 insertions(+), 30 deletions(-) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index 69d0f98618..f65fddac58 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -42,22 +42,10 @@ CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96 CONSTANT: NSOpenGLPFAVirtualScreenCount 128 CONSTANT: NSOpenGLCPSwapInterval 222 -: ( attributes -- pixelfmt ) - NSOpenGLPixelFormat -> alloc swap [ - % - NSOpenGLPFADepthSize , 16 , - ! NSOpenGLPFARendererID , kCGLRendererGenericFloatID , - ! NSOpenGLPFASupersample , - ! NSOpenGLPFASampleBuffers , 1 , - ! NSOpenGLPFASamples , 8 , - 0 , - ] int-array{ } make - -> initWithAttributes: - -> autorelease ; - -: ( class dim -- view ) - [ -> alloc 0 0 ] dip first2 - NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array +: ( class dim pixel-format -- view ) + [ -> alloc ] + [ [ 0 0 ] dip first2 ] + [ handle>> ] tri* -> initWithFrame:pixelFormat: dup 1 -> setPostsBoundsChangedNotifications: dup 1 -> setPostsFrameChangedNotifications: ; diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 362305c8f7..fbc713ac9a 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -1,14 +1,15 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math arrays assocs cocoa cocoa.application -command-line kernel memory namespaces cocoa.messages +command-line kernel memory namespaces cocoa.messages classes cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.nibs sequences ui ui.private ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds ui.backend.cocoa.views core-foundation core-foundation.run-loop core-graphics.types threads math.rectangles fry libc generalizations alien.c-types cocoa.views -combinators io.thread locals ; +combinators io.thread locals ui.pixel-formats +specialized-arrays.int literals core-graphics ; IN: ui.backend.cocoa TUPLE: handle ; @@ -20,6 +21,57 @@ C: offscreen-handle SINGLETON: cocoa-ui-backend +NSOpenGLPFA ( attribute -- NSOpenGLPFAs ) + +CONSTANT: attribute>NSOpenGLPFA-map H{ + { double-buffered { $ NSOpenGLPFADoubleBuffer } } + { stereo { $ NSOpenGLPFAStereo } } + { offscreen { $ NSOpenGLPFAOffScreen } } + { fullscreen { $ NSOpenGLPFAFullScreen } } + { windowed { $ NSOpenGLPFAWindow } } + { accelerated { $ NSOpenGLPFAAccelerated } } + { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } } + { robust { $ NSOpenGLPFARobust } } + { backing-store { $ NSOpenGLPFABackingStore } } + { multisampled { $ NSOpenGLPFAMultisample } } + { supersampled { $ NSOpenGLPFASupersample } } + { sample-alpha { $ NSOpenGLPFASampleAlpha } } + { color-float { $ NSOpenGLPFAColorFloat } } + { color-bits { $ NSOpenGLPFAColorSize } } + { alpha-bits { $ NSOpenGLPFAAlphaSize } } + { accum-bits { $ NSOpenGLPFAAccumSize } } + { depth-bits { $ NSOpenGLPFADepthSize } } + { stencil-bits { $ NSOpenGLPFAStencilSize } } + { aux-buffers { $ NSOpenGLPFAAuxBuffers } } + { sample-buffers { $ NSOpenGLPFASampleBuffers } } + { samples { $ NSOpenGLPFASamples } } +} + +M: object >NSOpenGLPFA + drop { } ; +M: symbol >NSOpenGLPFA + attribute>NSOpenGLPFA-map at [ { } ] unless* ; +M: pixel-format-attribute >NSOpenGLPFA + dup class attribute>NSOpenGLPFA-map at + [ swap value>> suffix ] + [ drop { } ] if ; + +PRIVATE> + +M: cocoa-ui-backend (make-pixel-format) + [ >NSOpenGLPFA ] map concat >int-array + NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ; + +M: cocoa-ui-backend (free-pixel-format) + -> release ; + +M: cocoa-ui-backend (pixel-format-attribute) + attribute>NSOpenGLPFA-map at + [ first 0 [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ] + [ f ] if* ; + TUPLE: pasteboard handle ; C: pasteboard @@ -70,7 +122,7 @@ M: cocoa-ui-backend fullscreen* ( world -- ? ) handle>> view>> -> isInFullScreenMode zero? not ; M:: cocoa-ui-backend (open-window) ( world -- ) - world dim>> :> view + [ [ dim>> ] dip ] with-world-pixel-format :> view view world world>NSRect :> window view -> release world view register-window @@ -97,18 +149,19 @@ M: cocoa-ui-backend raise-window* ( world -- ) ] when* ; : pixel-size ( pixel-format -- size ) - 0 [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ] - keep *int -3 shift ; + color-bits pixel-format-attribute -3 shift ; : offscreen-buffer ( world pixel-format -- alien w h pitch ) [ dim>> first2 ] [ pixel-size ] bi* { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ; -: gadget-offscreen-context ( world -- context buffer ) - NSOpenGLPFAOffScreen 1array - [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ] - [ offscreen-buffer ] 2bi - 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ; +:: gadget-offscreen-context ( world -- context buffer ) + world world-pixel-format-attributes offscreen suffix + [ + :> pf + NSOpenGLContext -> alloc pf handle>> f -> initWithFormat:shareContext: + dup world pf offscreen-buffer -> setOffScreen:width:height:rowbytes: + ] with-disposal ; M: cocoa-ui-backend (open-offscreen-buffer) ( world -- ) dup gadget-offscreen-context >>handle drop ; diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 602c9bec73..4a16e3bd37 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -365,8 +365,8 @@ CLASS: { -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 CGLSetParameter drop ; -: ( dim -- view ) - FactorView swap [ sync-refresh-to-screen ] keep ; +: ( dim pixel-format -- view ) + [ FactorView ] 2dip [ sync-refresh-to-screen ] keep ; : save-position ( world window -- ) -> frame CGRect-top-left 2array >>window-loc drop ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index a186de7670..d4162fa630 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.commands ; +ui.commands ui.pixel-formats destructors ; IN: ui.gadgets.worlds TUPLE: world < track @@ -149,3 +149,12 @@ M: world handle-gesture ( gesture gadget -- ? ) : close-global ( world global -- ) [ get-global find-world eq? ] keep '[ f _ set-global ] when ; + +GENERIC: world-pixel-format-attributes ( world -- attributes ) + +M: world world-pixel-format-attributes + { windowed double-buffered T{ depth-bits { value 16 } } } ; + +: with-world-pixel-format ( world quot -- ) + [ dup world-pixel-format-attributes ] + dip with-disposal ; inline diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 09450f2c72..66de98ea1c 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -1,7 +1,7 @@ USING: destructors math ui.backend ; IN: ui.pixel-formats -SINGLETONS: +SYMBOLS: double-buffered stereo offscreen From 0c718a047c32779e95d65fad4f3d720bffd2b9e9 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 1 May 2009 10:40:33 -0500 Subject: [PATCH 12/58] frp docs fixed --- extra/ui/frp/frp-docs.factor | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor index a6f625cc59..af44567e46 100644 --- a/extra/ui/frp/frp-docs.factor +++ b/extra/ui/frp/frp-docs.factor @@ -1,36 +1,46 @@ -USING: ui.frp help.syntax help.markup monads sequences ; +USING: help.markup help.syntax models monads sequences +ui.gadgets.buttons ui.gadgets.tracks ; IN: ui.frp ! Layout utilities HELP: , +{ $values { "uiitem" "a gadget or model" } } { $description "Used in a series of gadgets created by a box, accumulating the gadget" } ; HELP: -> +{ $values { "uiitem" "a gadget or model" } { "model" model } } { $description "Like " { $link , } "but passes its model on for further use." } ; HELP: +{ $values { "gadgets" "a list of gadgets" } { "track" track } } { $syntax "[ gadget , gadget , ... ] " } { $description "Creates an horizontal track containing the gadgets listed in the quotation" } ; HELP: +{ $values { "gadgets" "a list of gadgets" } { "track" track } } { $syntax "[ gadget , gadget , ... ] " } { $description "Creates an vertical track containing the gadgets listed in the quotation" } ; ! Gadgets HELP: +{ $values { "text" "the button's label" } { "button" button } } { $description "Creates an button whose model updates on clicks" } ; HELP: -{ $description "Creates a model that merges the updates of two others" } ; +{ $values { "models" "a list of models" } { "model" merge-model } } +{ $description "Creates a model that merges the updates of others" } ; HELP: +{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } } { $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ; HELP: +{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } } { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ; HELP: switch +{ $values { "signal1" model } { "signal2" model } { "signal'" model } } { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ; ARTICLE: { "frp" "instances" } "FRP Instances" -"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. " -"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ; +"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. " +"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ; From 471fe2c2729c2359cf841909f155bac04bdb6cd3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 May 2009 10:41:27 -0500 Subject: [PATCH 13/58] rename lines to stream-lines rename cnotents to stream-contents --- basis/ftp/client/client.factor | 2 +- basis/io/encodings/string/string.factor | 2 +- basis/xmode/code2html/code2html.factor | 2 +- core/checksums/checksums.factor | 2 +- core/io/files/files.factor | 4 ++-- core/io/io-docs.factor | 15 +++++++++++++-- core/io/io.factor | 10 ++++++++-- core/parser/parser.factor | 2 +- extra/contributors/contributors.factor | 2 +- extra/mason/common/common.factor | 2 +- 10 files changed, 30 insertions(+), 13 deletions(-) diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor index 14877110d3..9d51ba259e 100644 --- a/basis/ftp/client/client.factor +++ b/basis/ftp/client/client.factor @@ -66,7 +66,7 @@ ERROR: ftp-error got expected ; : list ( url -- ftp-response ) utf8 open-passive-client ftp-list - lines + stream-lines swap >>strings read-response 226 ftp-assert parse-list ; diff --git a/basis/io/encodings/string/string.factor b/basis/io/encodings/string/string.factor index 5e57a943a9..3659939fb0 100644 --- a/basis/io/encodings/string/string.factor +++ b/basis/io/encodings/string/string.factor @@ -4,7 +4,7 @@ USING: io io.streams.byte-array ; IN: io.encodings.string : decode ( byte-array encoding -- string ) - contents ; + stream-contents ; : encode ( string encoding -- byte-array ) [ write ] with-byte-writer ; diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor index 3fb5a532c9..b5141f6cc4 100644 --- a/basis/xmode/code2html/code2html.factor +++ b/basis/xmode/code2html/code2html.factor @@ -24,7 +24,7 @@ IN: xmode.code2html [XML XML] ; :: htmlize-stream ( path stream -- xml ) - stream lines + stream stream-lines [ "" ] [ path over first find-mode htmlize-lines ] if-empty :> input default-stylesheet :> stylesheet diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 98d36b21c3..82918b6f81 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -13,7 +13,7 @@ GENERIC: checksum-stream ( stream checksum -- value ) GENERIC: checksum-lines ( lines checksum -- value ) M: checksum checksum-stream - [ contents ] dip checksum-bytes ; + [ stream-contents ] dip checksum-bytes ; M: checksum checksum-lines [ B{ CHAR: \n } join ] dip checksum-bytes ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 1bc282e956..0f3041e670 100644 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -20,13 +20,13 @@ HOOK: (file-appender) io-backend ( path -- stream ) swap normalize-path (file-appender) swap ; : file-lines ( path encoding -- seq ) - lines ; + stream-lines ; : with-file-reader ( path encoding quot -- ) [ ] dip with-input-stream ; inline : file-contents ( path encoding -- seq ) - contents ; + stream-contents ; : with-file-writer ( path encoding quot -- ) [ ] dip with-output-stream ; inline diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 740152f294..96222eaa55 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -221,10 +221,14 @@ HELP: bl { $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." } $io-error ; -HELP: lines +HELP: stream-lines { $values { "stream" "an input stream" } { "seq" "a sequence of strings" } } { $description "Reads lines of text until the stream is exhausted, collecting them in a sequence of strings." } ; +HELP: lines +{ $values { "seq" "a sequence of strings" } } +{ $description "Reads lines of text until from the " { $link input-stream } " until it is exhausted, collecting them in a sequence of strings." } ; + HELP: each-line { $values { "quot" { $quotation "( str -- )" } } } { $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ; @@ -233,11 +237,16 @@ HELP: each-block { $values { "quot" { $quotation "( block -- )" } } } { $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ; -HELP: contents +HELP: stream-contents { $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } } { $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." } $io-error ; +HELP: contents +{ $values { "seq" "a string, byte array or " { $link f } } } +{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs" { $link f } "." } +$io-error ; + ARTICLE: "stream-protocol" "Stream protocol" "The stream protocol consists of a large number of generic words, many of which are optional." $nl @@ -347,9 +356,11 @@ $nl "First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":" { $subsection stream-print } "Processing lines one by one:" +{ $subsection stream-lines } { $subsection lines } { $subsection each-line } "Processing blocks of data:" +{ $subsection stream-contents } { $subsection contents } { $subsection each-block } "Copying the contents of one stream to another:" diff --git a/core/io/io.factor b/core/io/io.factor index 74bba7769e..b43098bcd4 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -68,9 +68,12 @@ SYMBOL: error-stream : bl ( -- ) " " write ; -: lines ( stream -- seq ) +: stream-lines ( stream -- seq ) [ [ readln dup ] [ ] produce nip ] with-input-stream ; +: lines ( -- seq ) + input-stream get stream-lines ; + : each-line ( quot -- ) [ readln ] each-morsel ; inline -: contents ( stream -- seq ) +: stream-contents ( stream -- seq ) [ [ 65536 read-partial dup ] [ ] produce nip concat f like ] with-input-stream ; +: contents ( -- seq ) + input-stream get stream-contents ; + : each-block ( quot: ( block -- ) -- ) [ 8192 read-partial ] each-morsel ; inline diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 7908f40cbe..7915dc69e0 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -272,7 +272,7 @@ print-use-hook [ [ ] ] initialize : parse-stream ( stream name -- quot ) [ [ - lines dup parse-fresh + stream-lines dup parse-fresh [ nip ] [ finish-parsing ] 2bi forget-smudged ] with-source-file diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 1879c52826..73bee76c0a 100755 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -7,7 +7,7 @@ IN: contributors : changelog ( -- authors ) image parent-directory [ - "git log --pretty=format:%an" ascii lines + "git log --pretty=format:%an" ascii stream-lines ] with-directory ; : patch-counts ( authors -- assoc ) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 285a684f06..b255b351f0 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -16,7 +16,7 @@ M: output-process-error error. : try-output-process ( command -- ) >process +stdout+ >>stderr utf8 - [ contents ] [ dup wait-for-process ] bi* + [ stream-contents ] [ dup wait-for-process ] bi* 0 = [ 2drop ] [ output-process-error ] if ; HOOK: really-delete-tree os ( path -- ) From d9a9e16fd78b36558d547027e9f670b2161c4ea5 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 1 May 2009 11:06:20 -0500 Subject: [PATCH 14/58] added file-trees vocab --- extra/file-trees/file-trees-tests.factor | 4 ++++ extra/file-trees/file-trees.factor | 23 +++++++++++++++++++++++ 2 files changed, 27 insertions(+) create mode 100644 extra/file-trees/file-trees-tests.factor create mode 100644 extra/file-trees/file-trees.factor diff --git a/extra/file-trees/file-trees-tests.factor b/extra/file-trees/file-trees-tests.factor new file mode 100644 index 0000000000..dbb8f9f5d8 --- /dev/null +++ b/extra/file-trees/file-trees-tests.factor @@ -0,0 +1,4 @@ +USING: kernel file-trees ; +IN: file-trees.tests +{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3" +"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop \ No newline at end of file diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor new file mode 100644 index 0000000000..788291c0a2 --- /dev/null +++ b/extra/file-trees/file-trees.factor @@ -0,0 +1,23 @@ +USING: accessors delegate delegate.protocols io.pathnames +kernel locals namespaces sequences vectors +tools.annotations prettyprint ; +IN: file-trees + +TUPLE: tree node children ; +CONSULT: sequence-protocol tree children>> [ node>> ] map ; + +: ( start -- tree ) V{ } clone + [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ; + +DEFER: (tree-insert) + +: tree-insert ( path tree -- ) [ unclip ] [ children>> ] bi* (tree-insert) ; +:: (tree-insert) ( path-rest path-head tree-children -- ) + tree-children [ node>> path-head node>> = ] find nip + [ path-rest swap tree-insert ] + [ + path-head tree-children push + path-rest [ path-head tree-insert ] unless-empty + ] if* ; +: create-tree ( file-list -- tree ) [ path-components ] map + t [ [ tree-insert ] curry each ] keep ; \ No newline at end of file From ac2557b4a78416c7d60e93d9a20438b222aa9a71 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 1 May 2009 11:06:48 -0500 Subject: [PATCH 15/58] frp changes --- extra/ui/frp/frp.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index f5c0f1bd10..aa7c44ee03 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -14,11 +14,12 @@ M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ; M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ; M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; -: ( model quot -- table ) - frp-table new-line-gadget dup >>renderer swap >>quot swap >>model +: ( model -- table ) + frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color transparent >>column-line-color ; +: ( model -- table ) [ 1array ] >>quot ; : ( -- field ) f ; ! Layout utilities @@ -27,11 +28,11 @@ GENERIC: output-model ( gadget -- model ) M: gadget output-model model>> ; M: frp-table output-model selected-value>> ; -GENERIC: , ( object -- ) +GENERIC: , ( uiitem -- ) M: gadget , make:, ; M: model , activate-model ; -GENERIC: -> ( object -- model ) +GENERIC: -> ( uiitem -- model ) M: gadget -> dup make:, output-model ; M: model -> dup , ; M: table -> dup , selected-value>> ; From e701e048847eaff1c6aebb0f967fb755297871ad Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 19:34:04 +0200 Subject: [PATCH 16/58] added small introduction article for mongodb added mongodb root vocab --- extra/mongodb/driver/driver-docs.factor | 5 ----- extra/mongodb/mongodb-docs.factor | 27 +++++++++++++++++++++++++ extra/mongodb/mongodb.factor | 8 ++++++++ 3 files changed, 35 insertions(+), 5 deletions(-) create mode 100644 extra/mongodb/mongodb-docs.factor create mode 100644 extra/mongodb/mongodb.factor diff --git a/extra/mongodb/driver/driver-docs.factor b/extra/mongodb/driver/driver-docs.factor index 1086105306..7dbf564df9 100644 --- a/extra/mongodb/driver/driver-docs.factor +++ b/extra/mongodb/driver/driver-docs.factor @@ -280,9 +280,4 @@ HELP: with-db } { $description "executes a quotation with the given mdb instance in its context" } ; -ARTICLE: "mongodb.driver" "MongoDB factor driver" -{ $vocab-link "mongodb.driver" } -; - -ABOUT: "mongodb.driver" diff --git a/extra/mongodb/mongodb-docs.factor b/extra/mongodb/mongodb-docs.factor new file mode 100644 index 0000000000..ff8a769993 --- /dev/null +++ b/extra/mongodb/mongodb-docs.factor @@ -0,0 +1,27 @@ +USING: assocs help.markup help.syntax kernel quotations ; +IN: mongodb + +ARTICLE: "mongodb" "MongoDB factor integration" +"The " { $vocab-link "mongodb" } " vocabulary provides two different interfaces to the MongoDB document-oriented database" +{ $heading "Low-level driver" } +"The " { $vocab-link "mongodb.driver" } " vocabulary provides a low-level interface to MongoDB." +{ $unchecked-example + "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " + "[ \"mycollection\" [ H{ { \"name\" \"Alfred\" } { \"age\" 57 } } save ] " + " [ ageIdx [ \"age\" asc ] key-spec ensure-index ]" + " [ H{ { \"age\" H{ { \"$gt\" 50 } } } } find-one ] tri ] with-db " + "" } +{ $heading "Highlevel tuple integration" } +"The " { $vocab-link "mongodb.tuple" } " vocabulary lets you define persistent tuples that can be stored to and retrieved from a MongoDB database" +{ $unchecked-example + "USING: mongodb.driver mongodb.tuple fry ;" + "MDBTUPLE: person name age ; " + "person \"persons\" { { \"age\" +fieldindex+ } } define-persistent " + "\"db\" \"127.0.0.1\" 27017 " + "person new \"Alfred\" >>name 57 >>age" + "'[ _ save-tuple person new 57 >>age select-tuple ] with-db" + "" } +; + +ABOUT: "mongodb" \ No newline at end of file diff --git a/extra/mongodb/mongodb.factor b/extra/mongodb/mongodb.factor new file mode 100644 index 0000000000..c5417cc3ac --- /dev/null +++ b/extra/mongodb/mongodb.factor @@ -0,0 +1,8 @@ +USING: vocabs.loader ; + +IN: mongodb + +"mongodb.connection" require +"mongodb.driver" require +"mongodb.tuple" require + From 8aa655bae38c54238074d56b25853011c42a5227 Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Fri, 1 May 2009 19:49:09 +0200 Subject: [PATCH 17/58] added metadata files (authors,tags,summary) to all vocabs --- extra/bson/authors.txt | 1 + extra/bson/constants/authors.txt | 1 + extra/bson/constants/summary.txt | 1 + extra/bson/reader/authors.txt | 1 + extra/bson/reader/summary.txt | 1 + extra/bson/summary.txt | 1 + extra/bson/writer/authors.txt | 1 + extra/bson/writer/summary.txt | 1 + extra/mongodb/authors.txt | 1 + extra/mongodb/benchmark/authors.txt | 1 + extra/mongodb/benchmark/summary.txt | 1 + extra/mongodb/connection/authors.txt | 1 + extra/mongodb/connection/summary.txt | 1 + extra/mongodb/mmm/authors.txt | 1 + extra/mongodb/mmm/summary.txt | 1 + extra/mongodb/msg/authors.txt | 1 + extra/mongodb/msg/summary.txt | 1 + extra/mongodb/operations/authors.txt | 1 + extra/mongodb/operations/summary.txt | 1 + extra/mongodb/summary.txt | 1 + extra/mongodb/tags.txt | 1 + extra/mongodb/tuple/authors.txt | 1 + extra/mongodb/tuple/collection/authors.txt | 1 + extra/mongodb/tuple/collection/summary.txt | 1 + extra/mongodb/tuple/index/authors.txt | 1 + extra/mongodb/tuple/index/summary.txt | 1 + extra/mongodb/tuple/persistent/authors.txt | 1 + extra/mongodb/tuple/persistent/summary.txt | 1 + extra/mongodb/tuple/state/authors.txt | 1 + extra/mongodb/tuple/state/summary.txt | 1 + extra/mongodb/tuple/summary.txt | 1 + 31 files changed, 31 insertions(+) create mode 100644 extra/bson/authors.txt create mode 100644 extra/bson/constants/authors.txt create mode 100644 extra/bson/constants/summary.txt create mode 100644 extra/bson/reader/authors.txt create mode 100644 extra/bson/reader/summary.txt create mode 100644 extra/bson/summary.txt create mode 100644 extra/bson/writer/authors.txt create mode 100644 extra/bson/writer/summary.txt create mode 100644 extra/mongodb/authors.txt create mode 100644 extra/mongodb/benchmark/authors.txt create mode 100644 extra/mongodb/benchmark/summary.txt create mode 100644 extra/mongodb/connection/authors.txt create mode 100644 extra/mongodb/connection/summary.txt create mode 100644 extra/mongodb/mmm/authors.txt create mode 100644 extra/mongodb/mmm/summary.txt create mode 100644 extra/mongodb/msg/authors.txt create mode 100644 extra/mongodb/msg/summary.txt create mode 100644 extra/mongodb/operations/authors.txt create mode 100644 extra/mongodb/operations/summary.txt create mode 100644 extra/mongodb/summary.txt create mode 100644 extra/mongodb/tags.txt create mode 100644 extra/mongodb/tuple/authors.txt create mode 100644 extra/mongodb/tuple/collection/authors.txt create mode 100644 extra/mongodb/tuple/collection/summary.txt create mode 100644 extra/mongodb/tuple/index/authors.txt create mode 100644 extra/mongodb/tuple/index/summary.txt create mode 100644 extra/mongodb/tuple/persistent/authors.txt create mode 100644 extra/mongodb/tuple/persistent/summary.txt create mode 100644 extra/mongodb/tuple/state/authors.txt create mode 100644 extra/mongodb/tuple/state/summary.txt create mode 100644 extra/mongodb/tuple/summary.txt diff --git a/extra/bson/authors.txt b/extra/bson/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/bson/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/bson/constants/authors.txt b/extra/bson/constants/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/bson/constants/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/bson/constants/summary.txt b/extra/bson/constants/summary.txt new file mode 100644 index 0000000000..11b05920ef --- /dev/null +++ b/extra/bson/constants/summary.txt @@ -0,0 +1 @@ +Shared constants and classes diff --git a/extra/bson/reader/authors.txt b/extra/bson/reader/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/bson/reader/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/bson/reader/summary.txt b/extra/bson/reader/summary.txt new file mode 100644 index 0000000000..384fe07a42 --- /dev/null +++ b/extra/bson/reader/summary.txt @@ -0,0 +1 @@ +BSON to Factor deserializer diff --git a/extra/bson/summary.txt b/extra/bson/summary.txt new file mode 100644 index 0000000000..58604e6990 --- /dev/null +++ b/extra/bson/summary.txt @@ -0,0 +1 @@ +BSON reader and writer diff --git a/extra/bson/writer/authors.txt b/extra/bson/writer/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/bson/writer/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/bson/writer/summary.txt b/extra/bson/writer/summary.txt new file mode 100644 index 0000000000..5dc8501bcb --- /dev/null +++ b/extra/bson/writer/summary.txt @@ -0,0 +1 @@ +Factor to BSON serializer diff --git a/extra/mongodb/authors.txt b/extra/mongodb/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/benchmark/authors.txt b/extra/mongodb/benchmark/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/benchmark/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/benchmark/summary.txt b/extra/mongodb/benchmark/summary.txt new file mode 100644 index 0000000000..5d0e4f5e1c --- /dev/null +++ b/extra/mongodb/benchmark/summary.txt @@ -0,0 +1 @@ +serialization/deserialization and insert/query benchmarks for mongodb.driver diff --git a/extra/mongodb/connection/authors.txt b/extra/mongodb/connection/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/connection/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/connection/summary.txt b/extra/mongodb/connection/summary.txt new file mode 100644 index 0000000000..44cfb3f0ec --- /dev/null +++ b/extra/mongodb/connection/summary.txt @@ -0,0 +1 @@ +low-level connection handling for mongodb.driver diff --git a/extra/mongodb/mmm/authors.txt b/extra/mongodb/mmm/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/mmm/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/mmm/summary.txt b/extra/mongodb/mmm/summary.txt new file mode 100644 index 0000000000..0670873053 --- /dev/null +++ b/extra/mongodb/mmm/summary.txt @@ -0,0 +1 @@ +mongo-message-monitor - a small proxy to introspect messages send to MongoDB diff --git a/extra/mongodb/msg/authors.txt b/extra/mongodb/msg/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/msg/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/msg/summary.txt b/extra/mongodb/msg/summary.txt new file mode 100644 index 0000000000..daff8c279b --- /dev/null +++ b/extra/mongodb/msg/summary.txt @@ -0,0 +1 @@ +message primitives for the communication with MongoDB diff --git a/extra/mongodb/operations/authors.txt b/extra/mongodb/operations/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/operations/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/operations/summary.txt b/extra/mongodb/operations/summary.txt new file mode 100644 index 0000000000..ab9f94e04f --- /dev/null +++ b/extra/mongodb/operations/summary.txt @@ -0,0 +1 @@ +low-level message reading and writing diff --git a/extra/mongodb/summary.txt b/extra/mongodb/summary.txt new file mode 100644 index 0000000000..87c5b2d527 --- /dev/null +++ b/extra/mongodb/summary.txt @@ -0,0 +1 @@ +MongoDB Factor integration diff --git a/extra/mongodb/tags.txt b/extra/mongodb/tags.txt new file mode 100644 index 0000000000..aa0d57e895 --- /dev/null +++ b/extra/mongodb/tags.txt @@ -0,0 +1 @@ +database diff --git a/extra/mongodb/tuple/authors.txt b/extra/mongodb/tuple/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/tuple/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/tuple/collection/authors.txt b/extra/mongodb/tuple/collection/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/tuple/collection/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/tuple/collection/summary.txt b/extra/mongodb/tuple/collection/summary.txt new file mode 100644 index 0000000000..e568b51c48 --- /dev/null +++ b/extra/mongodb/tuple/collection/summary.txt @@ -0,0 +1 @@ +tuple class MongoDB collection handling diff --git a/extra/mongodb/tuple/index/authors.txt b/extra/mongodb/tuple/index/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/tuple/index/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/tuple/index/summary.txt b/extra/mongodb/tuple/index/summary.txt new file mode 100644 index 0000000000..e4a15492be --- /dev/null +++ b/extra/mongodb/tuple/index/summary.txt @@ -0,0 +1 @@ +tuple class index handling diff --git a/extra/mongodb/tuple/persistent/authors.txt b/extra/mongodb/tuple/persistent/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/tuple/persistent/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/tuple/persistent/summary.txt b/extra/mongodb/tuple/persistent/summary.txt new file mode 100644 index 0000000000..46f32e4caf --- /dev/null +++ b/extra/mongodb/tuple/persistent/summary.txt @@ -0,0 +1 @@ +tuple to MongoDB storable conversion (and back) diff --git a/extra/mongodb/tuple/state/authors.txt b/extra/mongodb/tuple/state/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/tuple/state/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/tuple/state/summary.txt b/extra/mongodb/tuple/state/summary.txt new file mode 100644 index 0000000000..f879133465 --- /dev/null +++ b/extra/mongodb/tuple/state/summary.txt @@ -0,0 +1 @@ +client-side persistent tuple state handling diff --git a/extra/mongodb/tuple/summary.txt b/extra/mongodb/tuple/summary.txt new file mode 100644 index 0000000000..6c79de23d6 --- /dev/null +++ b/extra/mongodb/tuple/summary.txt @@ -0,0 +1 @@ +persist tuple instances into MongoDB From b45ea14d39f83bfd3b446f019cf8f21025a00a07 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 1 May 2009 12:56:52 -0500 Subject: [PATCH 18/58] compilation fixes --- basis/cocoa/views/views-docs.factor | 11 ++----- basis/ui/backend/cocoa/cocoa.factor | 32 +++++++++++---------- basis/ui/gadgets/worlds/worlds.factor | 1 + basis/ui/pixel-formats/pixel-formats.factor | 7 +++-- 4 files changed, 26 insertions(+), 25 deletions(-) diff --git a/basis/cocoa/views/views-docs.factor b/basis/cocoa/views/views-docs.factor index 3b533f98c3..871326fcd4 100644 --- a/basis/cocoa/views/views-docs.factor +++ b/basis/cocoa/views/views-docs.factor @@ -1,13 +1,9 @@ -USING: help.syntax help.markup ; +USING: help.syntax help.markup ui.pixel-formats ; IN: cocoa.views -HELP: -{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } } -{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ; - HELP: -{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "view" "a new " { $snippet "NSOpenGLView" } } } -{ $description "Creates a new instance of the specified class, giving it a default pixel format and the given size." } ; +{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "pixel-format" pixel-format } { "view" "a new " { $snippet "NSOpenGLView" } } } +{ $description "Creates a new instance of the specified class, giving it the specified pixel format and size." } ; HELP: view-dim { $values { "view" "an " { $snippet "NSView" } } { "dim" "a pair of real numbers" } } @@ -18,7 +14,6 @@ HELP: mouse-location { $description "Outputs the current mouse location." } ; ARTICLE: "cocoa-view-utils" "Cocoa view utilities" -{ $subsection } { $subsection } { $subsection view-dim } { $subsection mouse-location } ; diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index fbc713ac9a..8a91dfd94d 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -1,15 +1,15 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors math arrays assocs cocoa cocoa.application -command-line kernel memory namespaces cocoa.messages classes -cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types -cocoa.windows cocoa.classes cocoa.nibs sequences ui ui.private -ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds -ui.backend.cocoa.views core-foundation core-foundation.run-loop -core-graphics.types threads math.rectangles fry libc -generalizations alien.c-types cocoa.views -combinators io.thread locals ui.pixel-formats -specialized-arrays.int literals core-graphics ; +USING: accessors alien.c-types arrays assocs classes cocoa +cocoa.application cocoa.classes cocoa.messages cocoa.nibs +cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types +cocoa.views cocoa.windows combinators command-line +core-foundation core-foundation.run-loop core-graphics +core-graphics.types destructors fry generalizations io.thread +kernel libc literals locals math math.rectangles memory +namespaces sequences specialized-arrays.int threads ui +ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets +ui.gadgets.worlds ui.pixel-formats ui.private words.symbol ; IN: ui.backend.cocoa TUPLE: handle ; @@ -56,12 +56,12 @@ M: symbol >NSOpenGLPFA M: pixel-format-attribute >NSOpenGLPFA dup class attribute>NSOpenGLPFA-map at [ swap value>> suffix ] - [ drop { } ] if ; + [ drop { } ] if* ; PRIVATE> M: cocoa-ui-backend (make-pixel-format) - [ >NSOpenGLPFA ] map concat >int-array + [ >NSOpenGLPFA ] map concat 0 suffix >int-array NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ; M: cocoa-ui-backend (free-pixel-format) @@ -70,7 +70,7 @@ M: cocoa-ui-backend (free-pixel-format) M: cocoa-ui-backend (pixel-format-attribute) attribute>NSOpenGLPFA-map at [ first 0 [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ] - [ f ] if* ; + [ drop f ] if* ; TUPLE: pasteboard handle ; @@ -122,7 +122,8 @@ M: cocoa-ui-backend fullscreen* ( world -- ? ) handle>> view>> -> isInFullScreenMode zero? not ; M:: cocoa-ui-backend (open-window) ( world -- ) - [ [ dim>> ] dip ] with-world-pixel-format :> view + world [ [ dim>> ] dip ] + with-world-pixel-format :> view view world world>NSRect :> window view -> release world view register-window @@ -160,7 +161,8 @@ M: cocoa-ui-backend raise-window* ( world -- ) [ :> pf NSOpenGLContext -> alloc pf handle>> f -> initWithFormat:shareContext: - dup world pf offscreen-buffer -> setOffScreen:width:height:rowbytes: + dup world pf offscreen-buffer + 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ] with-disposal ; M: cocoa-ui-backend (open-offscreen-buffer) ( world -- ) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index d4162fa630..0328d453d4 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -153,6 +153,7 @@ M: world handle-gesture ( gesture gadget -- ? ) GENERIC: world-pixel-format-attributes ( world -- attributes ) M: world world-pixel-format-attributes + drop { windowed double-buffered T{ depth-bits { value 16 } } } ; : with-world-pixel-format ( world quot -- ) diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 66de98ea1c..3c41926c21 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -1,4 +1,4 @@ -USING: destructors math ui.backend ; +USING: accessors destructors kernel math ui.backend ; IN: ui.pixel-formats SYMBOLS: @@ -45,10 +45,13 @@ HOOK: (make-pixel-format) ui-backend ( attributes -- pixel-format-handle ) HOOK: (free-pixel-format) ui-backend ( pixel-format-handle -- ) HOOK: (pixel-format-attribute) ui-backend ( pixel-format-handle attribute-name -- value ) +ERROR: invalid-pixel-format-attributes attributes ; + TUPLE: pixel-format { handle read-only } ; : ( attributes -- pixel-format ) - (make-pixel-format) pixel-format boa ; + dup (make-pixel-format) + [ nip pixel-format boa ] [ invalid-pixel-format-attributes ] if* ; M: pixel-format dispose [ [ (free-pixel-format) ] when* f ] change-handle drop ; From cf6e78303b2cd222d6654d09be223bc60b88768a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 1 May 2009 13:21:57 -0500 Subject: [PATCH 19/58] don't really want that read-only! --- basis/ui/pixel-formats/pixel-formats.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 3c41926c21..3032c2551f 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -47,7 +47,7 @@ HOOK: (pixel-format-attribute) ui-backend ( pixel-format-handle attribute-name - ERROR: invalid-pixel-format-attributes attributes ; -TUPLE: pixel-format { handle read-only } ; +TUPLE: pixel-format handle ; : ( attributes -- pixel-format ) dup (make-pixel-format) From b3c9201da73c5cdf76e845e8ca6588fec782e17a Mon Sep 17 00:00:00 2001 From: "U-FROGGER\\erg" Date: Fri, 1 May 2009 14:02:26 -0500 Subject: [PATCH 20/58] fix GL-FUNCTION: syntax on wgl extension functions --- basis/windows/opengl32/opengl32.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor index d5e8fe9a66..d54d142b1f 100755 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax parser namespaces kernel -math math.bitwise windows.types init assocs +math math.bitwise windows.types init assocs splitting sequences libc opengl.gl opengl.gl.extensions opengl.gl.windows ; IN: windows.opengl32 @@ -103,7 +103,7 @@ FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ; ! WGL_ARB_extensions_string extension -GL-FUNCTION: char* wglGetExtensionsStringARB ( HDC hDC ) ; +GL-FUNCTION: char* wglGetExtensionsStringARB { } ( HDC hDC ) ; ! WGL_ARB_pixel_format extension @@ -160,7 +160,7 @@ CONSTANT: WGL_SWAP_UNDEFINED_ARB HEX: 202A CONSTANT: WGL_TYPE_RGBA_ARB HEX: 202B CONSTANT: WGL_TYPE_COLORINDEX_ARB HEX: 202C -GL-FUNCTION: BOOL wglGetPixelFormatAttribivARB ( +GL-FUNCTION: BOOL wglGetPixelFormatAttribivARB { } ( HDC hdc, int iPixelFormat, int iLayerPlane, @@ -169,7 +169,7 @@ GL-FUNCTION: BOOL wglGetPixelFormatAttribivARB ( int* piValues ) ; -GL-FUNCTION: BOOL wglGetPixelFormatAttribfvARB ( +GL-FUNCTION: BOOL wglGetPixelFormatAttribfvARB { } ( HDC hdc, int iPixelFormat, int iLayerPlane, @@ -178,7 +178,7 @@ GL-FUNCTION: BOOL wglGetPixelFormatAttribfvARB ( FLOAT* pfValues ) ; -GL-FUNCTION: BOOL wglChoosePixelFormatARB ( +GL-FUNCTION: BOOL wglChoosePixelFormatARB { } ( HDC hdc, int* piAttribIList, FLOAT* pfAttribFList, From 28ec9c3a3be7f21a4dfe463b7e06380cc0e93f26 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 May 2009 15:56:16 -0500 Subject: [PATCH 21/58] fix spacing in io docs --- core/io/io-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 96222eaa55..3469a81064 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -239,12 +239,12 @@ HELP: each-block HELP: stream-contents { $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } } -{ $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." } +{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." } $io-error ; HELP: contents { $values { "seq" "a string, byte array or " { $link f } } } -{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs" { $link f } "." } +{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." } $io-error ; ARTICLE: "stream-protocol" "Stream protocol" From 65b33c145c4936660461bfeb04249cddb0985f0c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 1 May 2009 16:16:40 -0500 Subject: [PATCH 22/58] GENERIC: support in functors --- basis/functors/functors-tests.factor | 26 ++++++++++++++++++++++++-- basis/functors/functors.factor | 20 ++++++++++++++------ 2 files changed, 38 insertions(+), 8 deletions(-) diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index b500d9f5ca..03bd21e58c 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -81,7 +81,26 @@ SYMBOL: W [ blorgh ] [ blorgh ] unit-test -GENERIC: some-generic ( a -- b ) +<< + +FUNCTOR: generic-test ( W -- ) + +W DEFINES ${W} + +WHERE + +GENERIC: W ( a -- b ) +M: object W ; +M: integer W 1 + ; + +;FUNCTOR + +"snurv" generic-test + +>> + +[ 2 ] [ 1 snurv ] unit-test +[ 3.0 ] [ 3.0 snurv ] unit-test ! Does replacing an ordinary word with a functor-generated one work? [ [ ] ] [ @@ -89,6 +108,7 @@ GENERIC: some-generic ( a -- b ) TUPLE: some-tuple ; : some-word ( -- ) ; + GENERIC: some-generic ( a -- b ) M: some-tuple some-generic ; SYMBOL: some-symbol "> "functors-test" parse-stream @@ -97,6 +117,7 @@ GENERIC: some-generic ( a -- b ) : test-redefinition ( -- ) [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test + [ t ] [ "some-generic" "functors.tests" lookup >boolean ] unit-test [ t ] [ "some-tuple" "functors.tests" lookup "some-generic" "functors.tests" lookup method >boolean @@ -109,13 +130,14 @@ FUNCTOR: redefine-test ( W -- ) W-word DEFINES ${W}-word W-tuple DEFINES-CLASS ${W}-tuple -W-generic IS ${W}-generic +W-generic DEFINES ${W}-generic W-symbol DEFINES ${W}-symbol WHERE TUPLE: W-tuple ; : W-word ( -- ) ; +GENERIC: W-generic ( a -- b ) M: W-tuple W-generic ; SYMBOL: W-symbol diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index ce069ac953..edd4932c66 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel quotations classes.tuple make combinators generic -words interpolate namespaces sequences io.streams.string fry -classes.mixin effects lexer parser classes.tuple.parser -effects.parser locals.types locals.parser generic.parser -locals.rewrite.closures vocabs.parser classes.parser -arrays accessors words.symbol ; +USING: accessors arrays classes.mixin classes.parser +classes.tuple classes.tuple.parser combinators effects +effects.parser fry generic generic.parser generic.standard +interpolate io.streams.string kernel lexer locals.parser +locals.rewrite.closures locals.types make namespaces parser +quotations sequences vocabs.parser words words.symbol ; IN: functors ! This is a hack @@ -18,6 +18,8 @@ IN: functors : define-declared* ( word def effect -- ) pick set-word define-declared ; +: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ; + TUPLE: fake-call-next-method ; TUPLE: fake-quotation seq ; @@ -104,6 +106,11 @@ SYNTAX: `INSTANCE: scan-param parsed \ add-mixin-instance parsed ; +SYNTAX: `GENERIC: + scan-param parsed + complete-effect parsed + \ define-simple-generic* parsed ; + SYNTAX: `inline [ word make-inline ] over push-all ; SYNTAX: `call-next-method T{ fake-call-next-method } parsed ; @@ -130,6 +137,7 @@ DEFER: ;FUNCTOR delimiter { "M:" POSTPONE: `M: } { "C:" POSTPONE: `C: } { ":" POSTPONE: `: } + { "GENERIC:" POSTPONE: `GENERIC: } { "INSTANCE:" POSTPONE: `INSTANCE: } { "SYNTAX:" POSTPONE: `SYNTAX: } { "SYMBOL:" POSTPONE: `SYMBOL: } From 2a7c26c20a9cf3d53ab607e6deeea4f04e51ef5a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 1 May 2009 16:33:49 -0500 Subject: [PATCH 23/58] shove cocoa pixel format attribute conversion into a functor so we can reuse it --- basis/ui/backend/cocoa/cocoa.factor | 23 +++++--------- basis/ui/pixel-formats/pixel-formats.factor | 33 ++++++++++++++++++++- 2 files changed, 39 insertions(+), 17 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 8a91dfd94d..ba0a7b9c7e 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -9,7 +9,8 @@ core-graphics.types destructors fry generalizations io.thread kernel libc literals locals math math.rectangles memory namespaces sequences specialized-arrays.int threads ui ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets -ui.gadgets.worlds ui.pixel-formats ui.private words.symbol ; +ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private +ui.private words.symbol ; IN: ui.backend.cocoa TUPLE: handle ; @@ -23,9 +24,7 @@ SINGLETON: cocoa-ui-backend NSOpenGLPFA ( attribute -- NSOpenGLPFAs ) - -CONSTANT: attribute>NSOpenGLPFA-map H{ +PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA H{ { double-buffered { $ NSOpenGLPFADoubleBuffer } } { stereo { $ NSOpenGLPFAStereo } } { offscreen { $ NSOpenGLPFAOffScreen } } @@ -49,28 +48,20 @@ CONSTANT: attribute>NSOpenGLPFA-map H{ { samples { $ NSOpenGLPFASamples } } } -M: object >NSOpenGLPFA - drop { } ; -M: symbol >NSOpenGLPFA - attribute>NSOpenGLPFA-map at [ { } ] unless* ; -M: pixel-format-attribute >NSOpenGLPFA - dup class attribute>NSOpenGLPFA-map at - [ swap value>> suffix ] - [ drop { } ] if* ; - PRIVATE> M: cocoa-ui-backend (make-pixel-format) - [ >NSOpenGLPFA ] map concat 0 suffix >int-array + >NSOpenGLPFA-int-array NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ; M: cocoa-ui-backend (free-pixel-format) -> release ; M: cocoa-ui-backend (pixel-format-attribute) - attribute>NSOpenGLPFA-map at + >NSOpenGLPFA + [ drop f ] [ first 0 [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ] - [ drop f ] if* ; + if-empty ; TUPLE: pasteboard handle ; diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 3032c2551f..5c16407135 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -1,4 +1,6 @@ -USING: accessors destructors kernel math ui.backend ; +USING: accessors assocs classes destructors functors kernel +lexer math parser sequences specialized-arrays.int ui.backend +words.symbol ; IN: ui.pixel-formats SYMBOLS: @@ -59,3 +61,32 @@ M: pixel-format dispose : pixel-format-attribute ( pixel-format attribute-name -- value ) [ handle>> ] dip (pixel-format-attribute) ; +PFA DEFINES >${NAME} +>PFA-int-array DEFINES >${NAME}-int-array + +WHERE + +GENERIC: >PFA ( attribute -- pfas ) + +M: object >PFA + drop { } ; +M: symbol >PFA + TABLE at [ { } ] unless* ; +M: pixel-format-attribute >PFA + dup class TABLE at + [ swap value>> suffix ] + [ drop { } ] if* ; + +: >PFA-int-array ( attribute -- int-array ) + [ >PFA ] map concat 0 suffix >int-array ; + +;FUNCTOR + +SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE: + scan scan-object define-pixel-format-attribute-table ; + +PRIVATE> From ce7ad9a42d28ebfe2d370757ec7b384c9c6c67a3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 May 2009 16:38:04 -0500 Subject: [PATCH 24/58] fix unit tests that call lines or contents --- basis/io/launcher/unix/unix-tests.factor | 14 +++++++------- .../io/servers/connection/connection-tests.factor | 2 +- basis/io/sockets/secure/unix/unix-tests.factor | 2 +- .../io/streams/byte-array/byte-array-tests.factor | 4 ++-- basis/ui/tools/listener/listener-tests.factor | 4 ++-- core/io/streams/c/c-tests.factor | 2 +- extra/irc/gitbot/gitbot.factor | 2 +- 7 files changed, 15 insertions(+), 15 deletions(-) diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor index f375bb41e8..99d45e4fd7 100644 --- a/basis/io/launcher/unix/unix-tests.factor +++ b/basis/io/launcher/unix/unix-tests.factor @@ -33,7 +33,7 @@ concurrency.promises threads unix.process ; "cat" "launcher-test-1" temp-file 2array - ascii contents + ascii stream-contents ] unit-test [ ] [ @@ -52,7 +52,7 @@ concurrency.promises threads unix.process ; "cat" "launcher-test-1" temp-file 2array - ascii contents + ascii stream-contents ] unit-test [ ] [ @@ -70,14 +70,14 @@ concurrency.promises threads unix.process ; "cat" "launcher-test-1" temp-file 2array - ascii contents + ascii stream-contents ] unit-test [ t ] [ "env" >>command { { "A" "B" } } >>environment - ascii lines + ascii stream-lines "A=B" swap member? ] unit-test @@ -86,7 +86,7 @@ concurrency.promises threads unix.process ; "env" >>command { { "A" "B" } } >>environment +replace-environment+ >>environment-mode - ascii lines + ascii stream-lines ] unit-test [ "hi\n" ] [ @@ -113,13 +113,13 @@ concurrency.promises threads unix.process ; "append-test" temp-file utf8 file-contents ] unit-test -[ t ] [ "ls" utf8 contents >boolean ] unit-test +[ t ] [ "ls" utf8 stream-contents >boolean ] unit-test [ "Hello world.\n" ] [ "cat" utf8 [ "Hello world.\n" write output-stream get dispose - input-stream get contents + input-stream get stream-contents ] with-stream ] unit-test diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index ae79290f0a..ab99531eb4 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ; dup start-server* sockets>> first addr>> port>> "port" set ] unit-test -[ "Hello world." ] [ "localhost" "port" get ascii drop contents ] unit-test +[ "Hello world." ] [ "localhost" "port" get ascii drop stream-contents ] unit-test diff --git a/basis/io/sockets/secure/unix/unix-tests.factor b/basis/io/sockets/secure/unix/unix-tests.factor index 7c4dcc17d1..f87ad93fbd 100644 --- a/basis/io/sockets/secure/unix/unix-tests.factor +++ b/basis/io/sockets/secure/unix/unix-tests.factor @@ -23,7 +23,7 @@ io.sockets.secure.unix.debug ; : client-test ( -- string ) [ - "127.0.0.1" "port" get ?promise ascii drop contents + "127.0.0.1" "port" get ?promise ascii drop stream-contents ] with-secure-context ; [ ] [ [ class name>> write ] server-test ] unit-test diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/basis/io/streams/byte-array/byte-array-tests.factor index 3cf52c6a78..0cd35dfa21 100644 --- a/basis/io/streams/byte-array/byte-array-tests.factor +++ b/basis/io/streams/byte-array/byte-array-tests.factor @@ -6,7 +6,7 @@ io.encodings.utf8 io kernel arrays strings namespaces ; [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test -[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 contents dup >array swap string? ] unit-test +[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 stream-contents dup >array swap string? ] unit-test [ B{ 121 120 } 0 ] [ B{ 0 121 120 0 0 0 0 0 0 } binary @@ -26,4 +26,4 @@ io.encodings.utf8 io kernel arrays strings namespaces ; 0 seek-end input-stream get stream-seek read1 ] with-byte-reader -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor index 45b94344a6..e06e17374f 100644 --- a/basis/ui/tools/listener/listener-tests.factor +++ b/basis/ui/tools/listener/listener-tests.factor @@ -75,7 +75,7 @@ CONSTANT: text "Hello world.\nThis is a test." [ ] [ [ "interactor" get register-self - "interactor" get contents "promise" get fulfill + "interactor" get stream-contents "promise" get fulfill ] in-thread ] unit-test @@ -150,4 +150,4 @@ CONSTANT: text "Hello world.\nThis is a test." [ ] [ "l" set ] unit-test [ ] [ "l" get com-scroll-up ] unit-test -[ ] [ "l" get com-scroll-down ] unit-test \ No newline at end of file +[ ] [ "l" get com-scroll-down ] unit-test diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 3dde9152d0..6a82d6d545 100644 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -5,6 +5,6 @@ IN: io.streams.c.tests [ "hello world" ] [ "hello world" "test.txt" temp-file ascii set-file-contents - "test.txt" temp-file "rb" fopen contents + "test.txt" temp-file "rb" fopen stream-contents >string ] unit-test diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor index d145b3bd2c..161a81d555 100644 --- a/extra/irc/gitbot/gitbot.factor +++ b/extra/irc/gitbot/gitbot.factor @@ -33,7 +33,7 @@ M: object handle-message drop ; "--pretty=format:%h %an: %s" , ".." glue , ] { } make - latin1 [ input-stream get lines ] with-process-reader ; + latin1 [ lines ] with-process-reader ; : updates ( from to -- lines ) git-log reverse From 0ad6d1fb7b40ee570008fab3af190a49004b6570 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 May 2009 19:58:24 -0500 Subject: [PATCH 25/58] add a few usages of iota, remove most 1+ and 1- from core --- basis/random/random.factor | 2 +- core/assocs/assocs.factor | 4 +-- core/bootstrap/primitives.factor | 2 +- core/checksums/crc32/crc32.factor | 2 +- core/classes/tuple/tuple-docs.factor | 2 +- core/classes/tuple/tuple.factor | 4 +-- core/combinators/combinators.factor | 4 +-- core/continuations/continuations-tests.factor | 2 +- core/generic/single/single.factor | 4 +-- core/generic/standard/standard.factor | 2 +- core/growable/growable.factor | 2 +- core/hashtables/hashtables.factor | 10 +++--- core/io/pathnames/pathnames.factor | 6 ++-- core/io/streams/sequence/sequence.factor | 4 +-- core/kernel/kernel-tests.factor | 2 +- core/layouts/layouts.factor | 6 ++-- core/lexer/lexer.factor | 4 +-- core/math/floats/floats-tests.factor | 4 +-- core/math/integers/integers-tests.factor | 4 +-- core/math/integers/integers.factor | 10 +++--- core/math/math.factor | 12 +++---- core/namespaces/namespaces.factor | 4 +-- core/quotations/quotations.factor | 4 +-- core/sequences/sequences.factor | 36 +++++++++---------- core/sorting/sorting.factor | 12 +++---- core/splitting/splitting.factor | 2 +- core/syntax/syntax-docs.factor | 4 +-- 27 files changed, 77 insertions(+), 77 deletions(-) diff --git a/basis/random/random.factor b/basis/random/random.factor index ebde3802b4..d972e1e7ac 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -54,7 +54,7 @@ PRIVATE> : randomize ( seq -- seq ) dup length [ dup 1 > ] - [ [ random ] [ 1- ] bi [ pick exchange ] keep ] + [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ] while drop ; : delete-random ( seq -- elt ) diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ec56cffff7..e783ef81c4 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -32,7 +32,7 @@ M: assoc assoc-like drop ; 3drop f ] [ 3dup nth-unsafe at* - [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if + [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if ] if ; inline recursive : search-alist ( key alist -- pair/f i/f ) @@ -105,7 +105,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) assoc-size 0 = ; : assoc-stack ( key seq -- value ) - [ length 1- ] keep (assoc-stack) ; flushable + [ length 1 - ] keep (assoc-stack) ; flushable : assoc-subset? ( assoc1 assoc2 -- ? ) [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index c0d51477ca..ec79185754 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -513,4 +513,4 @@ tuple } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number -"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared +"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared diff --git a/core/checksums/crc32/crc32.factor b/core/checksums/crc32/crc32.factor index 47da144d4d..7655ec8482 100644 --- a/core/checksums/crc32/crc32.factor +++ b/core/checksums/crc32/crc32.factor @@ -9,7 +9,7 @@ CONSTANT: crc32-polynomial HEX: edb88320 CONSTANT: crc32-table V{ } -256 [ +256 iota [ 8 [ [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless ] times >bignum diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index d76faddf15..4c55001aa1 100644 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -254,7 +254,7 @@ ARTICLE: "tuple-examples" "Tuple examples" " } ;" "" ": next-position ( role -- newrole )" - " positions [ index 1+ ] keep nth ;" + " positions [ index 1 + ] keep nth ;" "" ": promote ( employee -- employee )" " [ 1.2 * ] change-salary" diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index fb1e613b3e..225176f4e5 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -165,7 +165,7 @@ ERROR: bad-superclass class ; { [ , ] [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ] - [ superclasses length 1- , ] + [ superclasses length 1 - , ] [ superclasses [ [ , ] [ hashcode , ] bi ] each ] } cleave ] { } make ; @@ -331,7 +331,7 @@ GENERIC: tuple-hashcode ( n tuple -- x ) M: tuple tuple-hashcode [ - [ class hashcode ] [ tuple-size ] [ ] tri + [ class hashcode ] [ tuple-size iota ] [ ] tri [ rot ] dip [ swapd array-nth hashcode* sequence-hashcode-step ] 2curry each diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 1438edf3fa..7bf76fea30 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -123,7 +123,7 @@ ERROR: no-case object ; [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ; : hash-dispatch-quot ( table -- quot ) - [ length 1- [ fixnum-bitand ] curry ] keep + [ length 1 - [ fixnum-bitand ] curry ] keep [ dispatch ] curry append ; : hash-case-quot ( default assoc -- quot ) @@ -162,7 +162,7 @@ ERROR: no-case object ; ! recursive-hashcode : recursive-hashcode ( n obj quot -- code ) - pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline + pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline ! These go here, not in sequences and hashtables, since those ! two cannot depend on us diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index f4eeeefb77..6409fc588e 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -4,7 +4,7 @@ kernel.private accessors eval ; IN: continuations.tests : (callcc1-test) ( n obj -- n' obj ) - [ 1- dup ] dip ?push + [ 1 - dup ] dip ?push over 0 = [ "test-cc" get continue-with ] when (callcc1-test) ; diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 4fe9ce5a36..d8fa04edd6 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -178,7 +178,7 @@ M: echelon-dispatch-engine compile-engine M: tuple-dispatch-engine compile-engine tuple assumed [ echelons>> compile-engines - dup keys supremum 1+ f + dup keys supremum 1 + f [ swap update ] keep ] with-variable ; @@ -253,4 +253,4 @@ M: single-combination perform-combination [ mega-cache-quot define ] [ define-inline-cache-quot ] 2tri - ] with-combination ; \ No newline at end of file + ] with-combination ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 96c273e3f8..c8d1acba8f 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -28,7 +28,7 @@ CONSTANT: simple-combination T{ standard-combination f 0 } { 0 [ [ dup ] ] } { 1 [ [ over ] ] } { 2 [ [ pick ] ] } - [ 1- (picker) [ dip swap ] curry ] + [ 1 - (picker) [ dip swap ] curry ] } case ; M: standard-combination picker diff --git a/core/growable/growable.factor b/core/growable/growable.factor index c4970f98bd..684aab1158 100644 --- a/core/growable/growable.factor +++ b/core/growable/growable.factor @@ -35,7 +35,7 @@ M: growable set-length ( n seq -- ) ] if (>>length) ; -: new-size ( old -- new ) 1+ 3 * ; inline +: new-size ( old -- new ) 1 + 3 * ; inline : ensure ( n seq -- n seq ) growable-check diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index f95a7a7e67..0914134bb6 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -34,7 +34,7 @@ TUPLE: hashtable [ no-key ] [ 2dup hash@ (key@) ] if ; inline : ( n -- array ) - 1+ next-power-of-2 4 * ((empty)) ; inline + 1 + next-power-of-2 4 * ((empty)) ; inline : init-hash ( hash -- ) 0 >>count 0 >>deleted drop ; inline @@ -61,10 +61,10 @@ TUPLE: hashtable 1 fixnum+fast set-slot ; inline : hash-count+ ( hash -- ) - [ 1+ ] change-count drop ; inline + [ 1 + ] change-count drop ; inline : hash-deleted+ ( hash -- ) - [ 1+ ] change-deleted drop ; inline + [ 1 + ] change-deleted drop ; inline : (rehash) ( hash alist -- ) swap [ swapd set-at ] curry assoc-each ; inline @@ -77,7 +77,7 @@ TUPLE: hashtable [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline : grow-hash ( hash -- ) - [ [ >alist ] [ assoc-size 1+ ] bi ] keep + [ [ >alist ] [ assoc-size 1 + ] bi ] keep [ reset-hash ] keep swap (rehash) ; @@ -139,7 +139,7 @@ M: hashtable set-at ( value key hash -- ) PRIVATE> M: hashtable >alist - [ array>> [ length 2/ ] keep ] [ assoc-size ] bi [ + [ array>> [ length 2/ iota ] keep ] [ assoc-size ] bi [ [ [ [ 1 fixnum-shift-fast ] dip diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor index eba3e6a19f..30e9e6c206 100644 --- a/core/io/pathnames/pathnames.factor +++ b/core/io/pathnames/pathnames.factor @@ -17,7 +17,7 @@ SYMBOL: current-directory [ path-separator? ] trim-head ; : last-path-separator ( path -- n ? ) - [ length 1- ] keep [ path-separator? ] find-last-from ; + [ length 1 - ] keep [ path-separator? ] find-last-from ; HOOK: root-directory? io-backend ( path -- ? ) @@ -30,7 +30,7 @@ ERROR: no-parent-directory path ; dup root-directory? [ trim-tail-separators dup last-path-separator [ - 1+ cut + 1 + cut ] [ drop "." swap ] if @@ -113,7 +113,7 @@ PRIVATE> : file-name ( path -- string ) dup root-directory? [ trim-tail-separators - dup last-path-separator [ 1+ tail ] [ + dup last-path-separator [ 1 + tail ] [ drop special-path? [ file-name ] when ] if ] unless ; diff --git a/core/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor index 0f922a37cc..036bab2213 100644 --- a/core/io/streams/sequence/sequence.factor +++ b/core/io/streams/sequence/sequence.factor @@ -12,7 +12,7 @@ SLOT: i [ i>> ] [ underlying>> ] bi ; inline : next ( stream -- ) - [ 1+ ] change-i drop ; inline + [ 1 + ] change-i drop ; inline : sequence-read1 ( stream -- elt/f ) [ >sequence-stream< ?nth ] [ next ] bi ; inline @@ -45,4 +45,4 @@ M: growable stream-write1 push ; M: growable stream-write push-all ; M: growable stream-flush drop ; -INSTANCE: growable plain-writer \ No newline at end of file +INSTANCE: growable plain-writer diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index b58c744b05..5a88db4f9e 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -114,7 +114,7 @@ IN: kernel.tests ! Regression : (loop) ( a b c d -- ) [ pick ] dip swap [ pick ] dip swap - < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive + < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive : loop ( obj -- ) H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor index 00b9500211..42898fc085 100644 --- a/core/layouts/layouts.factor +++ b/core/layouts/layouts.factor @@ -49,13 +49,13 @@ SYMBOL: mega-cache-size cell-bits (first-bignum) ; inline : most-positive-fixnum ( -- n ) - first-bignum 1- ; inline + first-bignum 1 - ; inline : most-negative-fixnum ( -- n ) first-bignum neg ; inline : (max-array-capacity) ( b -- n ) - 5 - 2^ 1- ; inline + 5 - 2^ 1 - ; inline : max-array-capacity ( -- n ) cell-bits (max-array-capacity) ; inline @@ -64,7 +64,7 @@ SYMBOL: mega-cache-size bootstrap-cell-bits (first-bignum) ; : bootstrap-most-positive-fixnum ( -- n ) - bootstrap-first-bignum 1- ; + bootstrap-first-bignum 1 - ; : bootstrap-most-negative-fixnum ( -- n ) bootstrap-first-bignum neg ; diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor index 75341f0204..60157033d7 100644 --- a/core/lexer/lexer.factor +++ b/core/lexer/lexer.factor @@ -9,7 +9,7 @@ TUPLE: lexer text line line-text line-length column ; : next-line ( lexer -- ) dup [ line>> ] [ text>> ] bi ?nth >>line-text dup line-text>> length >>line-length - [ 1+ ] change-line + [ 1 + ] change-line 0 >>column drop ; @@ -39,7 +39,7 @@ GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if + 2dup nth CHAR: " eq? [ drop 1 + ] [ f skip ] if ] change-lexer-column ; : still-parsing? ( lexer -- ? ) diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor index 9f8f7b06fc..097e2c14aa 100644 --- a/core/math/floats/floats-tests.factor +++ b/core/math/floats/floats-tests.factor @@ -50,8 +50,8 @@ IN: math.floats.tests [ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ] unit-test -[ 2.0 ] [ 1.0 1+ ] unit-test -[ 0.0 ] [ 1.0 1- ] unit-test +[ 2.0 ] [ 1.0 1 + ] unit-test +[ 0.0 ] [ 1.0 1 - ] unit-test [ t ] [ 0.0 zero? ] unit-test [ t ] [ -0.0 zero? ] unit-test diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 6bd3e9b094..a9469ae91a 100644 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -206,8 +206,8 @@ unit-test [ 2. ] [ 2 1 ratio>float ] unit-test [ .5 ] [ 1 2 ratio>float ] unit-test [ .75 ] [ 3 4 ratio>float ] unit-test -[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test -[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test +[ 1. ] [ 2000 2^ 2000 2^ 1 + ratio>float ] unit-test +[ -1. ] [ 2000 2^ neg 2000 2^ 1 + ratio>float ] unit-test [ 0.4 ] [ 6 15 ratio>float ] unit-test [ HEX: 3fe553522d230931 ] diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 868d9fc02e..bb7fc107b2 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ; M: fixnum bit? neg shift 1 bitand 0 > ; : fixnum-log2 ( x -- n ) - 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ; + 0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ; M: fixnum (log2) fixnum-log2 ; @@ -86,7 +86,7 @@ M: bignum (log2) bignum-log2 ; ! provided with absolutely no warranty." ! First step: pre-scaling -: twos ( x -- y ) dup 1- bitxor log2 ; inline +: twos ( x -- y ) dup 1 - bitxor log2 ; inline : scale-denonimator ( den -- scaled-den scale' ) dup twos neg [ shift ] keep ; inline @@ -98,7 +98,7 @@ M: bignum (log2) bignum-log2 ; ! Second step: loop : shift-mantissa ( scale mantissa -- scale' mantissa' ) - [ 1+ ] [ 2/ ] bi* ; inline + [ 1 + ] [ 2/ ] bi* ; inline : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem ) [ 2dup /i log2 53 > ] @@ -107,7 +107,7 @@ M: bignum (log2) bignum-log2 ; ! Third step: post-scaling : unscaled-float ( mantissa -- n ) - 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline + 52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline : scale-float ( scale mantissa -- float' ) [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline @@ -126,7 +126,7 @@ M: bignum (log2) bignum-log2 ; ] [ pre-scale /f-loop over odd? - [ zero? [ 1+ ] unless ] [ drop ] if + [ zero? [ 1 + ] unless ] [ drop ] if post-scale ] if ] if ; inline diff --git a/core/math/math.factor b/core/math/math.factor index 993d8d0e76..8e0000326f 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -63,7 +63,7 @@ PRIVATE> : neg ( x -- -x ) 0 swap - ; inline : recip ( x -- y ) 1 swap / ; inline : sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline -: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline +: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline : rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable : 2^ ( n -- 2^n ) 1 swap shift ; inline : even? ( n -- ? ) 1 bitand zero? ; @@ -103,13 +103,13 @@ M: float fp-infinity? ( float -- ? ) ] if ; : next-power-of-2 ( m -- n ) - dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline + dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline : power-of-2? ( n -- ? ) - dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable + dup 0 <= [ drop f ] [ dup 1 - bitand zero? ] if ; foldable : align ( m w -- n ) - 1- [ + ] keep bitnot bitand ; inline + 1 - [ + ] keep bitnot bitand ; inline @@ -160,6 +160,6 @@ PRIVATE> [ call ] 2keep rot [ drop ] [ - [ 1- ] dip find-last-integer + [ 1 - ] dip find-last-integer ] if ] if ; inline recursive diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 310816cbf7..64cc328d19 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -29,8 +29,8 @@ PRIVATE> : inc ( variable -- ) 1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline : bind ( ns quot -- ) swap >n call ndrop ; inline -: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ; +: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ; : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline : with-scope ( quot -- ) 5 swap bind ; inline : with-variable ( value key quot -- ) [ associate ] dip bind ; inline -: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline \ No newline at end of file +: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor index 2c3b41ca4e..3245ac1e20 100644 --- a/core/quotations/quotations.factor +++ b/core/quotations/quotations.factor @@ -48,12 +48,12 @@ M: object literalize ; M: wrapper literalize ; -M: curry length quot>> length 1+ ; +M: curry length quot>> length 1 + ; M: curry nth over 0 = [ nip obj>> literalize ] - [ [ 1- ] dip quot>> nth ] + [ [ 1 - ] dip quot>> nth ] if ; INSTANCE: curry immutable-sequence diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 79195d1938..d60602fc71 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -198,7 +198,7 @@ C: reversed M: reversed virtual-seq seq>> ; -M: reversed virtual@ seq>> [ length swap - 1- ] keep ; +M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; M: reversed length seq>> length ; @@ -276,7 +276,7 @@ INSTANCE: repetition immutable-sequence ] 3keep ; inline : (copy) ( dst i src j n -- dst ) - dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; + dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ; inline recursive : prepare-subseq ( from to seq -- dst i src j n ) @@ -460,7 +460,7 @@ PRIVATE> [ nip find-last-integer ] (find-from) ; inline : find-last ( seq quot -- i elt ) - [ [ 1- ] dip find-last-integer ] (find) ; inline + [ [ 1 - ] dip find-last-integer ] (find) ; inline : all? ( seq quot -- ? ) (each) all-integers? ; inline @@ -556,7 +556,7 @@ PRIVATE> [ empty? not ] filter ; : mismatch ( seq1 seq2 -- i ) - [ min-length ] 2keep + [ min-length iota ] 2keep [ 2nth-unsafe = not ] 2curry find drop ; inline @@ -595,8 +595,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ; : (filter-here) ( quot: ( elt -- ? ) store scan seq -- ) 2dup length < [ [ move ] 3keep - [ nth-unsafe pick call [ 1+ ] when ] 2keep - [ 1+ ] dip + [ nth-unsafe pick call [ 1 + ] when ] 2keep + [ 1 + ] dip (filter-here) ] [ nip set-length drop ] if ; inline recursive @@ -612,20 +612,20 @@ PRIVATE> [ eq? not ] with filter-here ; : prefix ( seq elt -- newseq ) - over [ over length 1+ ] dip [ + over [ over length 1 + ] dip [ [ 0 swap set-nth-unsafe ] keep [ 1 swap copy ] keep ] new-like ; : suffix ( seq elt -- newseq ) - over [ over length 1+ ] dip [ + over [ over length 1 + ] dip [ [ [ over length ] dip set-nth-unsafe ] keep [ 0 swap copy ] keep ] new-like ; -: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ; +: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ; -: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ; +: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ; 2over = [ 2drop 2drop ] [ - [ [ 2over + pick ] dip move [ 1+ ] dip ] keep + [ [ 2over + pick ] dip move [ 1 + ] dip ] keep move-backward ] if ; @@ -641,13 +641,13 @@ PRIVATE> 2over = [ 2drop 2drop ] [ - [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep + [ [ pick [ dup dup ] dip + swap ] dip move 1 - ] keep move-forward ] if ; : (open-slice) ( shift from to seq ? -- ) [ - [ [ 1- ] bi@ ] dip move-forward + [ [ 1 - ] bi@ ] dip move-forward ] [ [ over - ] 2dip move-backward ] if ; @@ -667,7 +667,7 @@ PRIVATE> check-slice [ over [ - ] dip ] dip open-slice ; : delete-nth ( n seq -- ) - [ dup 1+ ] dip delete-slice ; + [ dup 1 + ] dip delete-slice ; : snip ( from to seq -- head tail ) [ swap head ] [ swap tail ] bi-curry bi* ; inline @@ -679,10 +679,10 @@ PRIVATE> snip-slice surround ; : remove-nth ( n seq -- seq' ) - [ [ { } ] dip dup 1+ ] dip replace-slice ; + [ [ { } ] dip dup 1 + ] dip replace-slice ; : pop ( seq -- elt ) - [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; + [ length 1 - ] [ [ nth ] [ shorten ] 2bi ] bi ; : exchange ( m n seq -- ) [ nip bounds-check 2drop ] @@ -692,7 +692,7 @@ PRIVATE> : reverse-here ( seq -- ) [ length 2/ ] [ length ] [ ] tri - [ [ over - 1- ] dip exchange-unsafe ] 2curry each ; + [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ; : reverse ( seq -- newseq ) [ @@ -799,7 +799,7 @@ PRIVATE> PRIVATE> : start* ( subseq seq n -- i ) - pick length pick length swap - 1+ + pick length pick length swap - 1 + [ (start) ] find-from swap [ 3drop ] dip ; diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 30ecb70ed9..f2fa6b8771 100644 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -29,13 +29,13 @@ TUPLE: merge [ [ [ 2drop ] dip nth-unsafe ] dip push ] [ pick 2 = [ [ - [ 2drop dup 1+ ] dip + [ 2drop dup 1 + ] dip [ nth-unsafe ] curry bi@ ] dip [ push ] curry bi@ ] [ pick 3 = [ [ - [ 2drop dup 1+ dup 1+ ] dip + [ 2drop dup 1 + dup 1 + ] dip [ nth-unsafe ] curry tri@ ] dip [ push ] curry tri@ ] [ [ nip subseq ] dip push-all ] if @@ -57,10 +57,10 @@ TUPLE: merge [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline : l-next ( merge -- ) - [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline + [ [ l-elt ] [ [ 1 + ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline : r-next ( merge -- ) - [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline + [ [ r-elt ] [ [ 1 + ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline : decide ( merge -- ? ) [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline @@ -129,8 +129,8 @@ TUPLE: merge while 2drop ; inline : each-pair ( seq quot -- ) - [ [ length 1+ 2/ ] keep ] dip - [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline + [ [ length 1 + 2/ ] keep ] dip + [ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline : (sort-pairs) ( i1 i2 seq quot accum -- ) [ 2dup length = ] 2dip rot [ diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor index 6d833c792e..c55a75baa6 100644 --- a/core/splitting/splitting.factor +++ b/core/splitting/splitting.factor @@ -55,7 +55,7 @@ PRIVATE> : (split) ( separators n seq -- ) 3dup rot [ member? ] curry find-from drop - [ [ swap subseq , ] 2keep 1+ swap (split) ] + [ [ swap subseq , ] 2keep 1 + swap (split) ] [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive : split, ( seq separators -- ) 0 rot (split) ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index e8f86faa9d..fff355fb95 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -749,7 +749,7 @@ HELP: " "" @@ -760,7 +760,7 @@ HELP: Date: Fri, 1 May 2009 20:07:14 -0500 Subject: [PATCH 26/58] adjust pixel format syntax. override offscreen-world pixel-format-attributes instead of special-casing --- basis/ui/backend/cocoa/cocoa.factor | 9 ++++----- basis/ui/pixel-formats/pixel-formats.factor | 6 +++--- extra/ui/offscreen/offscreen.factor | 3 +++ 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index ba0a7b9c7e..297996e9db 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -24,7 +24,7 @@ SINGLETON: cocoa-ui-backend [ - :> pf + world [ + nip :> pf NSOpenGLContext -> alloc pf handle>> f -> initWithFormat:shareContext: dup world pf offscreen-buffer 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip - ] with-disposal ; + ] with-world-pixel-format ; M: cocoa-ui-backend (open-offscreen-buffer) ( world -- ) dup gadget-offscreen-context >>handle drop ; diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 5c16407135..dc613604a6 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -63,7 +63,7 @@ M: pixel-format dispose PFA DEFINES >${NAME} >PFA-int-array DEFINES >${NAME}-int-array @@ -82,11 +82,11 @@ M: pixel-format-attribute >PFA [ drop { } ] if* ; : >PFA-int-array ( attribute -- int-array ) - [ >PFA ] map concat 0 suffix >int-array ; + [ >PFA ] map concat PERM prepend 0 suffix >int-array ; ;FUNCTOR SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE: - scan scan-object define-pixel-format-attribute-table ; + scan scan-object scan-object define-pixel-format-attribute-table ; PRIVATE> diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index 8d197eb844..c6669eb16f 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -6,6 +6,9 @@ IN: ui.offscreen TUPLE: offscreen-world < world ; +M: offscreen-world world-pixel-format-attributes + { offscreen T{ depth-bits { value 16 } } } ; + : ( gadget title status -- world ) offscreen-world new-world ; From 40b225f7651836a0cb6fb38ac4753053151c8e67 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 1 May 2009 22:14:26 -0500 Subject: [PATCH 27/58] Adding output>sequence and input nil [ t ] [ pi [ pi ] matches? ] unit-test [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test -[ ] [ 3 [ _ ] undo ] unit-test +[ ] [ 3 [ __ ] undo ] unit-test [ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test [ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test @@ -88,4 +90,7 @@ TUPLE: funny-tuple ; : ( -- funny-tuple ) \ funny-tuple boa ; : funny-tuple ( -- ) "OOPS" throw ; -[ ] [ [ ] [undo] drop ] unit-test \ No newline at end of file +[ ] [ [ ] [undo] drop ] unit-test + +[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test +[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input __ +sequences.private combinators mirrors splitting combinators.smart +combinators.short-circuit fry words.symbol generalizations +classes ; IN: inverse ERROR: fail ; M: fail summary drop "Matching failed" ; -: assure ( ? -- ) [ fail ] unless ; +: assure ( ? -- ) [ fail ] unless ; inline -: =/fail ( obj1 obj2 -- ) = assure ; +: =/fail ( obj1 obj2 -- ) = assure ; inline ! Inverse of a quotation @@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ; \ pick [ [ pick ] dip =/fail ] define-inverse \ tuck [ swapd [ =/fail ] keep ] define-inverse +\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse +\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse +\ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse +\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse + \ not define-involution -\ >boolean [ { t f } memq? assure ] define-inverse +\ >boolean [ dup { t f } memq? assure ] define-inverse \ tuple>array \ >tuple define-dual \ reverse define-involution -\ undo 1 [ [ call ] curry ] define-pop-inverse -\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse +\ undo 1 [ ] define-pop-inverse +\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse \ exp \ log define-dual \ sq \ sqrt define-dual @@ -173,16 +178,13 @@ ERROR: missing-literal ; 2curry ] define-pop-inverse -DEFER: _ -\ _ [ drop ] define-inverse +DEFER: __ +\ __ [ drop ] define-inverse : both ( object object -- object ) dupd assert= ; \ both [ dup ] define-inverse -: assure-length ( seq length -- seq ) - over length =/fail ; - { { >array array? } { >vector vector? } @@ -194,14 +196,23 @@ DEFER: _ { >string string? } { >sbuf sbuf? } { >quotation quotation? } -} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each +} [ '[ dup _ execute assure ] define-inverse ] assoc-each -! These actually work on all seqs--should they? -\ 1array [ 1 assure-length first ] define-inverse -\ 2array [ 2 assure-length first2 ] define-inverse -\ 3array [ 3 assure-length first3 ] define-inverse -\ 4array [ 4 assure-length first4 ] define-inverse -\ narray 1 [ [ firstn ] curry ] define-pop-inverse +: assure-length ( seq length -- ) + swap length =/fail ; inline + +: assure-array ( array -- array ) + dup array? assure ; inline + +: undo-narray ( array n -- ... ) + [ assure-array ] dip + [ assure-length ] [ firstn ] 2bi ; inline + +\ 1array [ 1 undo-narray ] define-inverse +\ 2array [ 2 undo-narray ] define-inverse +\ 3array [ 3 undo-narray ] define-inverse +\ 4array [ 4 undo-narray ] define-inverse +\ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse \ first [ 1array ] define-inverse \ first2 [ 2array ] define-inverse @@ -214,6 +225,12 @@ DEFER: _ \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse +: assure-same-class ( obj1 obj2 -- ) + [ class ] bi@ = assure ; inline + +\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ inputsequence ] ] define-pop-inverse + ! Constructor inverse : deconstruct-pred ( class -- quot ) "predicate" word-prop [ dupd call assure ] curry ; @@ -245,7 +262,7 @@ DEFER: _ ] recover ; inline : true-out ( quot effect -- quot' ) - out>> '[ @ __ ndrop t ] ; + out>> '[ @ _ ndrop t ] ; : false-recover ( effect -- quot ) in>> [ ndrop f ] curry [ recover-fail ] curry ; From 91e8e9522c60698caec955875d289dc40e21f6e1 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sat, 2 May 2009 08:22:14 -0500 Subject: [PATCH 28/58] str-fry can take non-literals --- extra/str-fry/str-fry.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor index aafdaa95d9..65e25e2580 100644 --- a/extra/str-fry/str-fry.factor +++ b/extra/str-fry/str-fry.factor @@ -1,4 +1,7 @@ -USING: kernel sequences splitting strings.parser ; +USING: fry.private kernel macros math sequences splitting strings.parser ; IN: str-fry -: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ; +: str-fry ( str -- quot ) "_" split + [ length 1 - [ncurry] [ call ] append ] + [ unclip [ [ rot glue ] reduce ] 2curry ] bi + prefix ; SYNTAX: I" parse-string rest str-fry over push-all ; \ No newline at end of file From 06359c08507fc844b2857f48a818ce79c4155d9c Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sat, 2 May 2009 10:32:18 -0500 Subject: [PATCH 29/58] str-fry fixes --- extra/str-fry/str-fry.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor index 65e25e2580..bfe74f37eb 100644 --- a/extra/str-fry/str-fry.factor +++ b/extra/str-fry/str-fry.factor @@ -1,7 +1,7 @@ -USING: fry.private kernel macros math sequences splitting strings.parser ; +USING: combinators effects kernel math sequences splitting +strings.parser ; IN: str-fry : str-fry ( str -- quot ) "_" split - [ length 1 - [ncurry] [ call ] append ] - [ unclip [ [ rot glue ] reduce ] 2curry ] bi - prefix ; + [ unclip [ [ rot glue ] reduce ] 2curry ] + [ length 1 - 1 [ call-effect ] 2curry ] bi ; SYNTAX: I" parse-string rest str-fry over push-all ; \ No newline at end of file From 621fed2dd54c305de9d0e218f6cbd82f7a755a1c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 12:31:33 -0500 Subject: [PATCH 30/58] need to pass world as arg to pixel-format hooks --- basis/ui/backend/cocoa/cocoa.factor | 6 +++--- basis/ui/gadgets/worlds/worlds.factor | 2 +- basis/ui/pixel-formats/pixel-formats.factor | 18 +++++++++--------- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 297996e9db..a4dbf670e2 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -51,14 +51,14 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{ PRIVATE> M: cocoa-ui-backend (make-pixel-format) - >NSOpenGLPFA-int-array + nip >NSOpenGLPFA-int-array NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ; M: cocoa-ui-backend (free-pixel-format) - -> release ; + handle>> -> release ; M: cocoa-ui-backend (pixel-format-attribute) - >NSOpenGLPFA + [ handle>> ] [ >NSOpenGLPFA ] bi* [ drop f ] [ first 0 [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ] if-empty ; diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 0328d453d4..c66e59b292 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -157,5 +157,5 @@ M: world world-pixel-format-attributes { windowed double-buffered T{ depth-bits { value 16 } } } ; : with-world-pixel-format ( world quot -- ) - [ dup world-pixel-format-attributes ] + [ dup dup world-pixel-format-attributes ] dip with-disposal ; inline diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index dc613604a6..98b1dab88e 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -43,23 +43,23 @@ TUPLE: buffer-level < pixel-format-attribute ; TUPLE: sample-buffers < pixel-format-attribute ; TUPLE: samples < pixel-format-attribute ; -HOOK: (make-pixel-format) ui-backend ( attributes -- pixel-format-handle ) -HOOK: (free-pixel-format) ui-backend ( pixel-format-handle -- ) -HOOK: (pixel-format-attribute) ui-backend ( pixel-format-handle attribute-name -- value ) +HOOK: (make-pixel-format) ui-backend ( world attributes -- pixel-format-handle ) +HOOK: (free-pixel-format) ui-backend ( pixel-format -- ) +HOOK: (pixel-format-attribute) ui-backend ( pixel-format attribute-name -- value ) -ERROR: invalid-pixel-format-attributes attributes ; +ERROR: invalid-pixel-format-attributes world attributes ; -TUPLE: pixel-format handle ; +TUPLE: pixel-format world handle ; -: ( attributes -- pixel-format ) - dup (make-pixel-format) +: ( world attributes -- pixel-format ) + 2dup (make-pixel-format) [ nip pixel-format boa ] [ invalid-pixel-format-attributes ] if* ; M: pixel-format dispose - [ [ (free-pixel-format) ] when* f ] change-handle drop ; + [ (free-pixel-format) ] [ f >>handle drop ] bi ; : pixel-format-attribute ( pixel-format attribute-name -- value ) - [ handle>> ] dip (pixel-format-attribute) ; + (pixel-format-attribute) ; Date: Sat, 2 May 2009 13:42:10 -0500 Subject: [PATCH 31/58] windows pixel-format backend --- basis/ui/backend/windows/windows.factor | 174 ++++++++++++++++++++++-- basis/windows/opengl32/opengl32.factor | 16 --- 2 files changed, 160 insertions(+), 30 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 76c0dc4e01..21bf5c74eb 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -10,11 +10,153 @@ windows.messages windows.types windows.offscreen windows.nt 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 windows.errors ; +io.encodings.utf16n windows.errors literals ui.pixel-formats +ui.pixel-formats.private memoize ; IN: ui.backend.windows SINGLETON: windows-ui-backend +> hDC>> (has-wglChoosePixelFormatARB?) ; + +: arb-make-pixel-format ( world attributes -- pf ) + [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 0 + [ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ; + +: arb-pixel-format-attribute ( pixel-format attribute -- value ) + >WGL_ARB + [ drop f ] [ + [ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip + first 0 + [ wglGetPixelFormatAttribivARB win32-error=0/f ] + keep *int + ] if-empty ; + +CONSTANT: pfd-flag-map H{ + { double-buffered $ PFD_DOUBLEBUFFER } + { stereo $ PFD_STEREO } + { offscreen $ PFD_DRAW_TO_BITMAP } + { fullscreen $ PFD_DRAW_TO_WINDOW } + { windowed $ PFD_DRAW_TO_WINDOW } + { software-rendered $ PFD_GENERIC_FORMAT } +} + +: >pfd-flag ( attribute -- value ) + pfd-flag-map at [ ] [ 0 ] if* ; + +: >pfd-flags ( attributes -- flags ) + [ >pfd-flag ] map [ bitor ] binary-reduce + PFD_SUPPORT_OPENGL bitor ; + +: attr-value ( attributes name -- value ) + [ instance? ] curry find nip + [ value>> ] [ 0 ] if* ; + +: >pfd ( attributes -- pfd ) + "PIXELFORMATDESCRIPTOR" + "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize + 1 over set-PIXELFORMATDESCRIPTOR-nVersion + over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags + PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType + over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits + over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits + over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits + over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits + over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits + over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits + over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits + over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits + over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits + over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits + over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits + over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits + over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers + PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask + nip ; + +: pfd-make-pixel-format ( world attributes -- pf ) + [ handle>> hDC>> ] [ >pfd ] bi* + ChoosePixelFormat dup win32-error=0/f ; + +: get-pfd ( pixel-format -- pfd ) + [ world>> handle>> hDC>> ] [ handle>> ] bi + "PIXELFORMATDESCRIPTOR" heap-size + "PIXELFORMATDESCRIPTOR" + [ DescribePixelFormat win32-error=0/f ] keep ; + +: pfd-flag? ( pfd flag -- ? ) + [ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ; + +: (pfd-pixel-format-attribute) ( pfd attribute -- value ) + { + { double-buffered [ PFD_DOUBLEBUFFER pfd-flag? ] } + { stereo [ PFD_STEREO pfd-flag? ] } + { offscreen [ PFD_DRAW_TO_BITMAP pfd-flag? ] } + { fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] } + { windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] } + { software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] } + { color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] } + { red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] } + { green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] } + { blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] } + { alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] } + { accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] } + { accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] } + { accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] } + { accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] } + { accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] } + { depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] } + { stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] } + { aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] } + [ 2drop f ] + } case ; + +: pfd-pixel-format-attribute ( pixel-format attribute -- value ) + [ get-pfd ] dip (pfd-pixel-format-attribute) ; + +M: windows-ui-backend (make-pixel-format) + over has-wglChoosePixelFormatARB? + [ arb-make-pixel-format ] [ pfd-make-pixel-format ] if ; + +M: windows-ui-backend (free-pixel-format) + drop ; + +M: windows-ui-backend (pixel-format-attribute) + over world>> has-wglChoosePixelFormatARB? + [ arb-pixel-format-attribute ] [ pfd-pixel-format-attribute ] if ; + +PRIVATE> + : lo-word ( wparam -- lo ) *short ; inline : hi-word ( wparam -- hi ) -16 shift lo-word ; inline : >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ; @@ -477,21 +619,22 @@ M: windows-ui-backend do-events f class-name-ptr set-global f msg-obj set-global ; -: setup-pixel-format ( hdc flags -- ) - 32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep - swapd SetPixelFormat win32-error=0/f ; - : get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ; : get-rc ( hDC -- hRC ) dup wglCreateContext dup win32-error=0/f [ wglMakeCurrent win32-error=0/f ] keep ; -: setup-gl ( hwnd -- hDC hRC ) - get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ; +: set-pixel-format ( pixel-format hdc -- ) + swap handle>> "PIXELFORMATDESCRIPTOR" SetPixelFormat win32-error=0/f ; + +: setup-gl ( world hwnd -- hDC hRC ) + get-dc + [ [ drop ] 2dip [ set-pixel-format ] [ ] [ get-rc ] tri ] + curry with-world-pixel-format ; M: windows-ui-backend (open-window) ( world -- ) - [ create-window [ setup-gl ] keep ] keep + [ dup create-window [ setup-gl ] keep ] keep [ f ] keep [ swap hWnd>> register-window ] 2keep dupd (>>handle) @@ -504,14 +647,17 @@ M: win-base select-gl-context ( handle -- ) M: win-base flush-gl-context ( handle -- ) hDC>> SwapBuffers win32-error=0/f ; -: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits ) - make-offscreen-dc-and-bitmap [ - [ dup offscreen-pfd-dwFlags setup-pixel-format ] - [ get-rc ] bi - ] 2dip ; +: setup-offscreen-gl ( world -- hDC hRC hBitmap bits ) + [ + swap + make-offscreen-dc-and-bitmap [ + [ set-pixel-format ] + [ get-rc ] bi + ] 2dip ; + ] with-world-pixel-format M: windows-ui-backend (open-offscreen-buffer) ( world -- ) - dup dim>> setup-offscreen-gl + dup setup-offscreen-gl >>handle drop ; M: windows-ui-backend (close-offscreen-buffer) ( handle -- ) diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor index d54d142b1f..4173332dc3 100755 --- a/basis/windows/opengl32/opengl32.factor +++ b/basis/windows/opengl32/opengl32.factor @@ -71,22 +71,6 @@ CONSTANT: WGL_SWAP_UNDERLAY13 HEX: 10000000 CONSTANT: WGL_SWAP_UNDERLAY14 HEX: 20000000 CONSTANT: WGL_SWAP_UNDERLAY15 HEX: 40000000 -: windowed-pfd-dwFlags ( -- n ) - { PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ; -: offscreen-pfd-dwFlags ( -- n ) - { PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL } flags ; - -! TODO: compare to http://www.nullterminator.net/opengl32.html -: make-pfd ( flags bits -- pfd ) - "PIXELFORMATDESCRIPTOR" - "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize - 1 over set-PIXELFORMATDESCRIPTOR-nVersion - rot over set-PIXELFORMATDESCRIPTOR-dwFlags - PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType - [ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep - 16 over set-PIXELFORMATDESCRIPTOR-cDepthBits - PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask ; - LIBRARY: gl From 623b16d048836ebd27d32db328b86e402e9736e0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 16:39:31 -0500 Subject: [PATCH 32/58] X11 backend for pixel formats --- basis/ui/backend/cocoa/cocoa.factor | 4 --- basis/ui/backend/x11/x11.factor | 44 +++++++++++++++++++++++++++-- basis/x11/glx/glx.factor | 11 -------- basis/x11/windows/windows.factor | 12 +++----- 4 files changed, 45 insertions(+), 26 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index a4dbf670e2..dd207aa4f9 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -22,8 +22,6 @@ C: offscreen-handle SINGLETON: cocoa-ui-backend - - M: cocoa-ui-backend (make-pixel-format) nip >NSOpenGLPFA-int-array NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ; diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index fb78abe917..5192fa1075 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -7,7 +7,8 @@ namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows x11.io io.encodings.string io.encodings.ascii io.encodings.utf8 combinators command-line math.vectors classes.tuple opengl.gl threads -math.rectangles environment ascii ; +math.rectangles environment ascii +ui.pixel-formats ui.pixel-formats.private ; IN: ui.backend.x11 SINGLETON: x11-ui-backend @@ -29,6 +30,40 @@ M: world configure-event ! In case dimensions didn't change relayout-1 ; +PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{ + { double-buffered { $ GLX_DOUBLEBUFFER } } + { stereo { $ GLX_STEREO } } + { color-bits { $ GLX_BUFFER_SIZE } } + { red-bits { $ GLX_RED_SIZE } } + { green-bits { $ GLX_GREEN_SIZE } } + { blue-bits { $ GLX_BLUE_SIZE } } + { alpha-bits { $ GLX_ALPHA_SIZE } } + { accum-red-bits { $ GLX_ACCUM_RED_SIZE } } + { accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } } + { accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } } + { accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } } + { depth-bits { $ GLX_DEPTH_SIZE } } + { stencil-bits { $ GLX_STENCIL_SIZE } } + { aux-buffers { $ GLX_AUX_BUFFERS } } + { sample-buffers { $ GLX_SAMPLE_BUFFERS } } + { samples { $ GLX_SAMPLES } } +} + +M: x11-ui-backend (make-pixel-format) + [ drop dpy get scr get ] dip + >glx-visual-int-array glXChooseVisual ; + +M: x11-ui-backend (free-pixel-format) + handle>> XFree ; + +M: x11-ui-backend (pixel-format-attribute) + [ dpy get ] 2dip + [ handle>> ] [ >glx-visual ] bi* + [ drop f ] [ + first [ dpy get ] 2dip + 0 [ glXGetConfig drop ] keep *int + ] if-empty ; + CONSTANT: modifiers { { S+ HEX: 1 } @@ -187,7 +222,8 @@ M: world client-event : gadget-window ( world -- ) dup - [ window-loc>> ] [ dim>> ] bi glx-window swap + [ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ] + with-world-pixel-format swap dup "Factor" create-xic [ window>> register-window ] [ >>handle drop ] 2bi ; @@ -274,7 +310,9 @@ M: x11-pixmap-handle flush-gl-context ( handle -- ) drop ; M: x11-ui-backend (open-offscreen-buffer) ( world -- ) - dup dim>> glx-pixmap >>handle drop ; + dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] + with-world-pixel-format + >>handle drop ; M: x11-ui-backend (close-offscreen-buffer) ( handle -- ) dpy get swap [ glx-pixmap>> glXDestroyGLXPixmap ] diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index b459b55f46..67ac0e8cc1 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -95,17 +95,6 @@ CONSTANT: GLX_RGBA_FLOAT_BIT HEX: 0004 ! GLX Events ! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks) -: choose-visual ( flags -- XVisualInfo* ) - [ dpy get scr get ] dip - [ - % - GLX_RGBA , - GLX_DEPTH_SIZE , 16 , - 0 , - ] int-array{ } make - glXChooseVisual - [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ; - : create-glx ( XVisualInfo* -- GLXContext ) [ dpy get ] dip f 1 glXCreateContext [ "Failed to create GLX context" throw ] unless* ; diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index 37da51e9b8..54cf205c14 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -53,11 +53,8 @@ IN: x11.windows dup ] dip auto-position ; -: glx-window ( loc dim -- window glx ) - GLX_DOUBLEBUFFER 1array choose-visual - [ create-window ] keep - [ create-glx ] keep - XFree ; +: glx-window ( loc dim visual -- window glx ) + [ create-window ] [ create-glx ] bi ; : create-pixmap ( dim visual -- pixmap ) [ [ { 0 0 } swap ] dip create-window ] [ @@ -74,9 +71,8 @@ IN: x11.windows : create-glx-pixmap ( dim visual -- pixmap glx-pixmap ) [ create-pixmap ] [ (create-glx-pixmap) ] bi ; -: glx-pixmap ( dim -- glx pixmap glx-pixmap ) - { } choose-visual - [ nip create-glx ] [ create-glx-pixmap ] [ nip XFree ] 2tri ; +: glx-pixmap ( dim visual -- glx pixmap glx-pixmap ) + [ nip create-glx ] [ create-glx-pixmap ] 2bi ; : destroy-window ( win -- ) dpy get swap XDestroyWindow drop ; From a7e2632faffedd4fb85b483fe0a6ab28731962f4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 16:46:58 -0500 Subject: [PATCH 33/58] check-world-pixel-format word that world subclasses can override to verify that the chosen pixel format meets their needs --- basis/ui/gadgets/worlds/worlds.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index c66e59b292..885f4138ff 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -152,10 +152,15 @@ M: world handle-gesture ( gesture gadget -- ? ) GENERIC: world-pixel-format-attributes ( world -- attributes ) +GENERIC# check-world-pixel-format 1 ( world pixel-format -- ) + M: world world-pixel-format-attributes drop { windowed double-buffered T{ depth-bits { value 16 } } } ; +M: world check-world-pixel-format + 2drop ; + : with-world-pixel-format ( world quot -- ) [ dup dup world-pixel-format-attributes ] - dip with-disposal ; inline + dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline From d96f6d3197b5b43b7c1f3007d9b9174f8b1698e1 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 17:54:45 -0500 Subject: [PATCH 34/58] oops, forgot backing-store support on windows. also "robust" is useless --- basis/ui/backend/cocoa/cocoa.factor | 1 - basis/ui/backend/windows/windows.factor | 2 ++ basis/ui/gadgets/worlds/worlds-docs.factor | 2 +- basis/ui/pixel-formats/pixel-formats.factor | 1 - 4 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index dd207aa4f9..5b1b4b0c2a 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -30,7 +30,6 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{ { windowed { $ NSOpenGLPFAWindow } } { accelerated { $ NSOpenGLPFAAccelerated } } { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } } - { robust { $ NSOpenGLPFARobust } } { backing-store { $ NSOpenGLPFABackingStore } } { multisampled { $ NSOpenGLPFAMultisample } } { supersampled { $ NSOpenGLPFASupersample } } diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 21bf5c74eb..cc0c30f05e 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -26,6 +26,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{ { windowed { $ WGL_DRAW_TO_WINDOW_ARB 1 } } { accelerated { $ WGL_ACCELERATION_ARB $ WGL_FULL_ACCELERATION_ARB } } { software-rendered { $ WGL_ACCELERATION_ARB $ WGL_NO_ACCELERATION_ARB } } + { backing-store { $ WGL_SWAP_METHOD_ARB $ WGL_SWAP_COPY_ARB } } { color-float { $ WGL_TYPE_RGBA_FLOAT_ARB 1 } } { color-bits { $ WGL_COLOR_BITS_ARB } } { red-bits { $ WGL_RED_BITS_ARB } } @@ -68,6 +69,7 @@ CONSTANT: pfd-flag-map H{ { offscreen $ PFD_DRAW_TO_BITMAP } { fullscreen $ PFD_DRAW_TO_WINDOW } { windowed $ PFD_DRAW_TO_WINDOW } + { backing-store $ PFD_SWAP_COPY } { software-rendered $ PFD_GENERIC_FORMAT } } diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index e3c1226f22..ad9f3f8d4f 100644 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -1,6 +1,6 @@ USING: ui.gadgets ui.render ui.text ui.text.private ui.gestures ui.backend help.markup help.syntax -models opengl strings ; +models opengl sequences strings ui.pixel-formats ; IN: ui.gadgets.worlds HELP: user-input diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 98b1dab88e..8b09402b0f 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -11,7 +11,6 @@ SYMBOLS: windowed accelerated software-rendered - robust backing-store multisampled supersampled From af6bf6603eb6b107ae024dc8eee51aa4e5b54950 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 18:22:45 -0500 Subject: [PATCH 35/58] docs for ui.pixel-formats --- basis/ui/pixel-formats/authors.txt | 1 + .../pixel-formats/pixel-formats-docs.factor | 190 ++++++++++++++++++ basis/ui/pixel-formats/pixel-formats.factor | 2 - basis/ui/pixel-formats/summary.txt | 1 + 4 files changed, 192 insertions(+), 2 deletions(-) create mode 100644 basis/ui/pixel-formats/authors.txt create mode 100644 basis/ui/pixel-formats/pixel-formats-docs.factor create mode 100644 basis/ui/pixel-formats/summary.txt diff --git a/basis/ui/pixel-formats/authors.txt b/basis/ui/pixel-formats/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/ui/pixel-formats/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor new file mode 100644 index 0000000000..188a92d8b8 --- /dev/null +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -0,0 +1,190 @@ +USING: destructors help.markup help.syntax kernel math multiline sequences ui.gadgets.worlds ; +IN: ui.pixel-formats + +ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes" +"The following pixel format attributes can be requested and queried of " { $link pixel-format } "s. Binary attributes are represented by the presence of a symbol in an attribute sequence:" +{ $subsection double-buffered } +{ $subsection stereo } +{ $subsection offscreen } +{ $subsection fullscreen } +{ $subsection windowed } +{ $subsection accelerated } +{ $subsection software-rendered } +{ $subsection backing-store } +{ $subsection multisampled } +{ $subsection supersampled } +{ $subsection sample-alpha } +{ $subsection color-float } +"Integer attributes are represented by a " { $link tuple } " with a single " { $snippet "value" } "slot:" +{ $subsection color-bits } +{ $subsection red-bits } +{ $subsection green-bits } +{ $subsection blue-bits } +{ $subsection alpha-bits } +{ $subsection accum-bits } +{ $subsection accum-red-bits } +{ $subsection accum-green-bits } +{ $subsection accum-blue-bits } +{ $subsection accum-alpha-bits } +{ $subsection depth-bits } +{ $subsection stencil-bits } +{ $subsection aux-buffers } +{ $subsection sample-buffers } +{ $subsection samples } +{ $examples +"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:" +{ $code <" +USING: kernel ui.worlds ui.pixel-formats ; +IN: ui.pixel-formats.examples + +TUPLE: picky-depth-buffered-world < world ; + +M: picky-depth-buffered-world world-pixel-format-attributes + drop { + double-buffered + T{ color-bits { value 24 } } + T{ depth-bits { value 24 } } + } ; + +M: picky-depth-buffered-world check-world-pixel-format + nip + [ double-buffered pixel-format-attribute 0 = [ "Not double buffered!" throw ] when ] + [ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ] + [ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ] + tri ; +"> } } +; + +HELP: double-buffered +{ $class-description "Requests a double-buffered pixel format." } ; +HELP: stereo +{ $class-description "Requests a stereoscopic pixel format." } ; + +HELP: offscreen +{ $class-description "Requests a pixel format suitable for offscreen rendering." } ; +HELP: fullscreen +{ $class-description "Requests a pixel format suitable for fullscreen rendering." } +{ $notes "On some window systems this is not distinct from " { $link windowed } "." } ; +HELP: windowed +{ $class-description "Requests a pixel format suitable for rendering to a window." } ; + +{ offscreen fullscreen windowed } related-words + +HELP: accelerated +{ $class-description "Requests a pixel format supported by GPU hardware acceleration." } ; +HELP: software-rendered +{ $class-description "Requests a pixel format only supported by the window system's default software renderer." } ; + +{ accelerated software-rendered } related-words + +HELP: backing-store +{ $class-description "Used with " { $link double-buffered } " to request a double-buffered pixel format where the back buffer contents are preserved and copied to the front when buffers are swapped." } ; + +{ double-buffered backing-store } related-words + +HELP: multisampled +{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of multisampling." } +{ $notes "On some window systems this is not distinct from " { $link supersampled } "." } ; + +HELP: supersampled +{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of supersampling." } +{ $notes "On some window systems this is not distinct from " { $link multisampled } "." } ; + +HELP: sample-alpha +{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ; + +HELP: color-float +{ $class-description "Requests a pixel format where the pixels are stored in floating-point format." } ; + +HELP: color-bits +{ $class-description "Requests a pixel format of at least " { $snippet "value" } " bits per pixel." } ; +HELP: red-bits +{ $class-description "Requests a pixel format with at least " { $snippet "value" } " red bits per pixel." } ; +HELP: green-bits +{ $class-description "Requests a pixel format with at least " { $snippet "value" } " green bits per pixel." } ; +HELP: blue-bits +{ $class-description "Requests a pixel format with at least " { $snippet "value" } " blue bits per pixel." } ; +HELP: alpha-bits +{ $class-description "Requests a pixel format with at least " { $snippet "value" } " alpha bits per pixel." } ; + +{ color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words + +HELP: accum-bits +{ $class-description "Requests a pixel format with an accumulation buffer of at least " { $snippet "value" } " bits per pixel." } ; +HELP: accum-red-bits +{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " red bits per pixel." } ; +HELP: accum-green-bits +{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " green bits per pixel." } ; +HELP: accum-blue-bits +{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " blue bits per pixel." } ; +HELP: accum-alpha-bits +{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " alpha bits per pixel." } ; + +{ accum-bits accum-red-bits accum-green-bits accum-blue-bits accum-alpha-bits } related-words + +HELP: depth-bits +{ $class-description "Requests a pixel format with a depth buffer of at least " { $snippet "value" } " bits per pixel." } ; + +HELP: stencil-bits +{ $class-description "Requests a pixel format with a stencil buffer of at least " { $snippet "value" } " bits per pixel." } ; + +HELP: aux-buffers +{ $class-description "Requests a pixel format with at least " { $snippet "value" } " auxiliary buffers." } ; + +HELP: sample-buffers +{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request a pixel format with at least " { $snippet "value" } " sampling buffers." } ; + +HELP: samples +{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request at least " { $snippet "value" } " samples per pixel." } ; + +{ multisampled supersampled sample-alpha sample-buffers samples } related-words + +HELP: world-pixel-format-attributes +{ $values { "world" world } { "attributes" sequence } } +{ $description "Returns the set of " { $link "ui.pixel-formats-attributes" } " that " { $snippet "world" } " requests when grafted. This generic can be overridden by subclasses of " { $snippet "world" } "." } +{ $notes "The pixel format provided by the window system will not necessarily exactly match the requested attributes. To verify required pixel format attributes, override " { $link check-world-pixel-format } "." } ; + +HELP: check-world-pixel-format +{ $values { "world" world } { "pixel-format" pixel-format } } +{ $description "Verifies that " { $snippet "pixel-format" } " fulfills the requirements of " { $snippet "world" } ". The default method does nothing. Subclasses can override this generic to perform their own checks on the pixel format." } ; + +HELP: pixel-format +{ $class-description "The type of pixel format objects. The tuple slot contents should be considered opaque by user code. To check the value of a pixel format's attributes, use the " { $link pixel-format-attribute } " word. Pixel format objects must be freed using the " { $link dispose } " word when they are no longer needed." } ; + +HELP: +{ $values { "world" world } { "attributes" sequence } { "pixel-format" pixel-format } } +{ $description "Requests a pixel format suitable for " { $snippet "world" } " with a set of " { $link "ui.pixel-formats-attributes" } ". If no pixel format can be found that satisfies the given attributes, an " { $link invalid-pixel-format-attributes } " error is thrown. Pixel format attributes not supported by the window system are ignored. The returned " { $snippet "pixel-format" } " must be released using the " { $link dispose } " word when it is no longer needed." } +{ $notes "Pixel formats don't normally need to be directly allocated by user code. If you need to control the pixel format requested by a window, subclass " { $snippet "world" } " and override the " { $link world-pixel-format-attributes } " and " { $link check-world-pixel-format } " words." +$nl +"The returned pixel format does not necessarily exactly match the requested attributes; the window system will try to find the format that best matches the given attributes. Use " { $link pixel-format-attribute } " to check the actual values of the attributes on the returned pixel format." } +; + +HELP: pixel-format-attribute +{ $values { "pixel-format" pixel-format } { "attribute-name" "one of the " { $link "ui.pixel-formats-attributes" } } { "value" object } } +{ $description "Returns the value of the requested " { $snippet "attribute-name" } " in " { $snippet "pixel-format" } ". If " { "attribute-name" } " is unsupported by the window system, " { $link f } " is returned." } ; + +HELP: invalid-pixel-format-attributes +{ $values { "world" world } { "attributes" sequence } } +{ $class-description "Thrown by " { $link } " when the window system is unable to find a pixel format for " { $snippet "world" } " that satisfies the requested " { $snippet "attributes" } "." } ; + +{ world-pixel-format-attributes check-world-pixel-format pixel-format pixel-format-attribute } +related-words + +ARTICLE: "ui.pixel-formats" "Pixel formats" +"The UI allows you to control the window system's OpenGL interface with a cross-platform set of pixel format specifiers:" +{ $subsection "ui.pixel-formats-attributes" } + +"Pixel formats can be requested using these attributes:" +{ $subsection pixel-format } +{ $subsection } +{ $subsection pixel-format-attribute } + +"If a request for a set of pixel format attributes cannot be satisfied, an error is thrown:" +{ $subsection invalid-pixel-format-attributes } + +"Pixel formats are requested as part of opening a window for a " { $link world } ". These generics can be overridden on " { $snippet "world" } " subclasses to control pixel format selection:" +{ $subsection world-pixel-format-attributes } +{ $subsection check-world-pixel-format } +; + +ABOUT: "ui.pixel-formats" diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 8b09402b0f..125f79eded 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -37,8 +37,6 @@ TUPLE: stencil-bits < pixel-format-attribute ; TUPLE: aux-buffers < pixel-format-attribute ; -TUPLE: buffer-level < pixel-format-attribute ; - TUPLE: sample-buffers < pixel-format-attribute ; TUPLE: samples < pixel-format-attribute ; diff --git a/basis/ui/pixel-formats/summary.txt b/basis/ui/pixel-formats/summary.txt new file mode 100644 index 0000000000..517f42458b --- /dev/null +++ b/basis/ui/pixel-formats/summary.txt @@ -0,0 +1 @@ +Cross-platform OpenGL context pixel format specifiers From 886d08733265b3213d905f82c94515c8e24de251 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 19:44:08 -0500 Subject: [PATCH 36/58] ui.backend.windows code cleanup --- basis/ui/backend/windows/windows.factor | 51 +++++++++++-------------- 1 file changed, 23 insertions(+), 28 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index cc0c30f05e..eff8db238b 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -16,6 +16,12 @@ IN: ui.backend.windows SINGLETON: windows-ui-backend +TUPLE: win-base hDC hRC ; +TUPLE: win < win-base hWnd world title ; +TUPLE: win-offscreen < win-base hBitmap bits ; +C: win +C: win-offscreen + clipboard set-global selection set-global ; -TUPLE: win-base hDC hRC ; -TUPLE: win < win-base hWnd world title ; -TUPLE: win-offscreen < win-base hBitmap bits ; -C: win -C: win-offscreen - SYMBOLS: msg-obj class-name-ptr mouse-captured ; : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline @@ -621,26 +621,24 @@ M: windows-ui-backend do-events f class-name-ptr set-global f msg-obj set-global ; -: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ; +: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ; -: get-rc ( hDC -- hRC ) - dup wglCreateContext dup win32-error=0/f - [ wglMakeCurrent win32-error=0/f ] keep ; +: get-rc ( world -- ) + handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f + [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ; : set-pixel-format ( pixel-format hdc -- ) swap handle>> "PIXELFORMATDESCRIPTOR" SetPixelFormat win32-error=0/f ; -: setup-gl ( world hwnd -- hDC hRC ) - get-dc - [ [ drop ] 2dip [ set-pixel-format ] [ ] [ get-rc ] tri ] - curry with-world-pixel-format ; +: setup-gl ( world -- ) + [ get-dc ] keep + [ swap [ hDC>> set-pixel-format ] [ get-rc ] bi ] + with-world-pixel-format ; M: windows-ui-backend (open-window) ( world -- ) - [ dup create-window [ setup-gl ] keep ] keep - [ f ] keep - [ swap hWnd>> register-window ] 2keep - dupd (>>handle) - hWnd>> show-window ; + [ dup create-window f f >>handle setup-gl ] + [ dup handle>> hWnd>> register-window ] + [ handle>> hWnd>> show-window ] tri ; M: win-base select-gl-context ( handle -- ) [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f @@ -650,17 +648,14 @@ M: win-base flush-gl-context ( handle -- ) hDC>> SwapBuffers win32-error=0/f ; : setup-offscreen-gl ( world -- hDC hRC hBitmap bits ) - [ - swap - make-offscreen-dc-and-bitmap [ - [ set-pixel-format ] - [ get-rc ] bi - ] 2dip ; - ] with-world-pixel-format + dup [ handle>> ] [ dim>> ] bi make-offscreen-dc-and-bitmap + [ >>hDC ] [ >>hBitmap ] [ >>bits ] tri* drop [ + swap [ hDC>> set-pixel-format ] [ get-rc ] bi + ] with-world-pixel-format ; M: windows-ui-backend (open-offscreen-buffer) ( world -- ) - dup setup-offscreen-gl - >>handle drop ; + win-offscreen new >>handle + setup-offscreen-gl ; M: windows-ui-backend (close-offscreen-buffer) ( handle -- ) [ hDC>> DeleteDC drop ] From aa142a1b52c2e99487a20430a30b9399e9ed058f Mon Sep 17 00:00:00 2001 From: "U-FROGGER\\erg" Date: Sat, 2 May 2009 20:36:31 -0500 Subject: [PATCH 37/58] fix windows ui --- basis/ui/backend/windows/windows.factor | 12 ++++++------ basis/ui/gadgets/worlds/worlds-docs.factor | 2 +- basis/ui/gadgets/worlds/worlds.factor | 0 basis/windows/gdi32/gdi32.factor | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) mode change 100644 => 100755 basis/ui/gadgets/worlds/worlds-docs.factor mode change 100644 => 100755 basis/ui/gadgets/worlds/worlds.factor diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index eff8db238b..24ae72740f 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -11,7 +11,7 @@ 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 windows.errors literals ui.pixel-formats -ui.pixel-formats.private memoize ; +ui.pixel-formats.private memoize classes ; IN: ui.backend.windows SINGLETON: windows-ui-backend @@ -83,7 +83,7 @@ CONSTANT: pfd-flag-map H{ pfd-flag-map at [ ] [ 0 ] if* ; : >pfd-flags ( attributes -- flags ) - [ >pfd-flag ] map [ bitor ] binary-reduce + [ >pfd-flag ] [ bitor ] map-reduce PFD_SUPPORT_OPENGL bitor ; : attr-value ( attributes name -- value ) @@ -632,11 +632,11 @@ M: windows-ui-backend do-events : setup-gl ( world -- ) [ get-dc ] keep - [ swap [ hDC>> set-pixel-format ] [ get-rc ] bi ] + [ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ] with-world-pixel-format ; M: windows-ui-backend (open-window) ( world -- ) - [ dup create-window f f >>handle setup-gl ] + [ dup create-window [ f f ] dip f f >>handle setup-gl ] [ dup handle>> hWnd>> register-window ] [ handle>> hWnd>> show-window ] tri ; @@ -647,10 +647,10 @@ M: win-base select-gl-context ( handle -- ) M: win-base flush-gl-context ( handle -- ) hDC>> SwapBuffers win32-error=0/f ; -: setup-offscreen-gl ( world -- hDC hRC hBitmap bits ) +: setup-offscreen-gl ( world -- ) dup [ handle>> ] [ dim>> ] bi make-offscreen-dc-and-bitmap [ >>hDC ] [ >>hBitmap ] [ >>bits ] tri* drop [ - swap [ hDC>> set-pixel-format ] [ get-rc ] bi + swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ] with-world-pixel-format ; M: windows-ui-backend (open-offscreen-buffer) ( world -- ) diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor old mode 100644 new mode 100755 index ad9f3f8d4f..9d4df189f2 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -1,6 +1,6 @@ USING: ui.gadgets ui.render ui.text ui.text.private ui.gestures ui.backend help.markup help.syntax -models opengl sequences strings ui.pixel-formats ; +models opengl sequences strings ; IN: ui.gadgets.worlds HELP: user-input diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor old mode 100644 new mode 100755 diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 9b7cd2e35e..0699c92be3 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1419,7 +1419,7 @@ DESTRUCTOR: DeleteDC ! FUNCTION: DeleteMetaFile FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ; DESTRUCTOR: DeleteObject -! FUNCTION: DescribePixelFormat +FUNCTION: int DescribePixelFormat ( HDC hdc, int iPixelFormat, UINT nBytes, PIXELFORMATDESCRIPTOR* ppfd ) ; ! FUNCTION: DeviceCapabilitiesExA ! FUNCTION: DeviceCapabilitiesExW ! FUNCTION: DPtoLP From 644c42d4e348eb033c9ccac82646ad36d1104e97 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 21:52:18 -0500 Subject: [PATCH 38/58] "ui-backend" variable can't be used to choose text backend --- basis/ui/text/text.factor | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor index 2edb20fc22..c1f05182e6 100755 --- a/basis/ui/text/text.factor +++ b/basis/ui/text/text.factor @@ -75,10 +75,8 @@ M: array draw-text USING: vocabs.loader namespaces system combinators ; -"ui-backend" get [ - { - { [ os macosx? ] [ "core-text" ] } - { [ os windows? ] [ "uniscribe" ] } - { [ os unix? ] [ "pango" ] } - } cond -] unless* "ui.text." prepend require \ No newline at end of file +{ + { [ os macosx? ] [ "core-text" ] } + { [ os windows? ] [ "uniscribe" ] } + { [ os unix? ] [ "pango" ] } +} cond "ui.text." prepend require From cc244cb6721bca042cae946969087c98cf812b0b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 21:54:25 -0500 Subject: [PATCH 39/58] break code->code docs<-docs dependency --- basis/ui/gadgets/worlds/worlds.factor | 4 ---- basis/ui/pixel-formats/pixel-formats-docs.factor | 9 ++++++++- basis/ui/pixel-formats/pixel-formats.factor | 5 +++++ 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 885f4138ff..171272dfc1 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -150,10 +150,6 @@ M: world handle-gesture ( gesture gadget -- ? ) : close-global ( world global -- ) [ get-global find-world eq? ] keep '[ f _ set-global ] when ; -GENERIC: world-pixel-format-attributes ( world -- attributes ) - -GENERIC# check-world-pixel-format 1 ( world pixel-format -- ) - M: world world-pixel-format-attributes drop { windowed double-buffered T{ depth-bits { value 16 } } } ; diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index 188a92d8b8..6f2485d249 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -1,6 +1,13 @@ -USING: destructors help.markup help.syntax kernel math multiline sequences ui.gadgets.worlds ; +USING: destructors help.markup help.syntax kernel math multiline sequences +vocabs.parser words ; IN: ui.pixel-formats +! break circular dependency +<< + "world" "ui.gadgets.worlds" create drop + "ui.gadgets.worlds" (use+) +>> + ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes" "The following pixel format attributes can be requested and queried of " { $link pixel-format } "s. Binary attributes are represented by the presence of a symbol in an attribute sequence:" { $subsection double-buffered } diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 125f79eded..52abf44362 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -87,3 +87,8 @@ SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE: scan scan-object scan-object define-pixel-format-attribute-table ; PRIVATE> + +GENERIC: world-pixel-format-attributes ( world -- attributes ) + +GENERIC# check-world-pixel-format 1 ( world pixel-format -- ) + From a0c8d0ae9e9d19b18cf4311832b5e798f50a7d27 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 21:55:19 -0500 Subject: [PATCH 40/58] fix x11 backend bugs --- basis/ui/backend/x11/x11.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 5192fa1075..76fd9fa30c 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/basis/ui/backend/x11/x11.factor @@ -7,7 +7,7 @@ namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows x11.io io.encodings.string io.encodings.ascii io.encodings.utf8 combinators command-line math.vectors classes.tuple opengl.gl threads -math.rectangles environment ascii +math.rectangles environment ascii literals ui.pixel-formats ui.pixel-formats.private ; IN: ui.backend.x11 @@ -59,8 +59,8 @@ M: x11-ui-backend (free-pixel-format) M: x11-ui-backend (pixel-format-attribute) [ dpy get ] 2dip [ handle>> ] [ >glx-visual ] bi* - [ drop f ] [ - first [ dpy get ] 2dip + [ 2drop f ] [ + first 0 [ glXGetConfig drop ] keep *int ] if-empty ; From fa524ce213d20223122fc898928575e05fb6e960 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 May 2009 22:13:01 -0500 Subject: [PATCH 41/58] fix circular dependency for reals --- basis/ui/pixel-formats/pixel-formats-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index 6f2485d249..207b757908 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -1,9 +1,10 @@ USING: destructors help.markup help.syntax kernel math multiline sequences -vocabs.parser words ; +vocabs vocabs.parser words ; IN: ui.pixel-formats ! break circular dependency << + "ui.gadgets.worlds" create-vocab drop "world" "ui.gadgets.worlds" create drop "ui.gadgets.worlds" (use+) >> From bd92f6c8ccb04c563b4425a0c62f01199096459d Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 3 May 2009 11:48:28 -0500 Subject: [PATCH 42/58] separated behaviors and events in frp --- extra/ui/frp/frp.factor | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index aa7c44ee03..f972a3f805 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -1,7 +1,7 @@ -USING: accessors arrays colors fonts fry kernel models +USING: accessors arrays colors fonts kernel models models.product monads sequences ui.gadgets ui.gadgets.buttons ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables -ui.gadgets.tracks ui.render ; +ui.gadgets.tracks ui.render ui.gadgets.scrollers ; QUALIFIED: make IN: ui.frp @@ -27,6 +27,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; GENERIC: output-model ( gadget -- model ) M: gadget output-model model>> ; M: frp-table output-model selected-value>> ; +M: model-field output-model field-model>> ; +M: scroller output-model children>> first model>> ; GENERIC: , ( uiitem -- ) M: gadget , make:, ; @@ -41,13 +43,16 @@ M: table -> dup , selected-value>> ; [ { } make:make ] dip swap [ f track-add ] each ; inline : ( gadgets type -- track ) [ ] [ [ model>> ] map ] bi >>model ; inline : ( gadgets -- track ) horizontal ; inline +: ( gadgets -- track ) horizontal ; inline : ( gadgets -- track ) vertical ; inline +: ( gadgets -- track ) vertical ; inline -! Model utilities +! !!! Model utilities TUPLE: multi-model < model ; -! M: multi-model model-activated dup model-changed ; : ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ; +! Events- discrete model utilities + TUPLE: merge-model < multi-model ; M: merge-model model-changed [ value>> ] dip set-model ; : ( models -- model ) merge-model ; @@ -57,15 +62,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke [ set-model ] [ 2drop ] if ; : ( model quot -- filter-model ) [ 1array filter-model ] dip >>quot ; +! Behaviors - continuous model utilities + TUPLE: fold-model < multi-model oldval quot ; M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ; -: ( oldval quot model -- model' ) 1array fold-model swap >>quot swap >>oldval ; +: ( oldval quot model -- model' ) 1array fold-model swap >>quot + swap [ >>oldval ] [ >>value ] bi ; -TUPLE: switch-model < multi-model switcher on ; -M: switch-model model-changed tuck [ switcher>> = ] 2keep - '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ; -: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] keep >>switcher ; +TUPLE: switch-model < multi-model original switcher on ; +M: switch-model model-changed 2dup switcher>> = + [ [ value>> ] [ t >>on ] bi* set-model ] + [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ; +M: switch-model model-activated [ original>> ] keep model-changed ; +: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep + [ >>original ] [ >>switcher ] bi* ; TUPLE: mapped < model model quot ; @@ -87,4 +98,4 @@ INSTANCE: gadget-monad monad INSTANCE: gadget monad M: gadget monad-of drop gadget-monad ; M: gadget-monad return drop swap >>model ; -M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; \ No newline at end of file +M: gadget >>= output-model [ swap call( x -- y ) ] curry ; \ No newline at end of file From 6fc5e7a75452a81f0f566929e403c8f9f0113d9b Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 3 May 2009 12:14:17 -0500 Subject: [PATCH 43/58] frp: switcher ignores f values --- extra/ui/frp/frp-docs.factor | 2 +- extra/ui/frp/frp.factor | 6 ++++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor index af44567e46..479a56e513 100644 --- a/extra/ui/frp/frp-docs.factor +++ b/extra/ui/frp/frp-docs.factor @@ -36,7 +36,7 @@ HELP: { $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } } { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ; -HELP: switch +HELP: { $values { "signal1" model } { "signal2" model } { "signal'" model } } { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ; diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index f972a3f805..6b146c8296 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -20,6 +20,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; focus-border-color >>focus-border-color transparent >>column-line-color ; : ( model -- table ) [ 1array ] >>quot ; +: ( -- table ) f ; + : ( -- field ) f ; ! Layout utilities @@ -72,10 +74,10 @@ M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi* TUPLE: switch-model < multi-model original switcher on ; M: switch-model model-changed 2dup switcher>> = - [ [ value>> ] [ t >>on ] bi* set-model ] + [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ] [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ; M: switch-model model-activated [ original>> ] keep model-changed ; -: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep +: ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep [ >>original ] [ >>switcher ] bi* ; TUPLE: mapped < model model quot ; From 7d020d8f2f8e6a1ad579634d177c4a9f3cfa7f33 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 3 May 2009 12:29:12 -0500 Subject: [PATCH 44/58] frp: set default val-quot --- extra/ui/frp/frp.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index 6b146c8296..699d034c72 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -18,7 +18,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; + transparent >>column-line-color [ ] >>val-quot ; +: ( -- table ) f ; : ( model -- table ) [ 1array ] >>quot ; : ( -- table ) f ; From 0ca6a6c63f195c7326baac282ebaa12d67abe595 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 3 May 2009 12:29:29 -0500 Subject: [PATCH 45/58] added gui for file-trees --- extra/file-trees/file-trees.factor | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor index 788291c0a2..eadfccdc4c 100644 --- a/extra/file-trees/file-trees.factor +++ b/extra/file-trees/file-trees.factor @@ -1,10 +1,10 @@ -USING: accessors delegate delegate.protocols io.pathnames -kernel locals namespaces sequences vectors -tools.annotations prettyprint ; +USING: accessors arrays delegate delegate.protocols +io.pathnames kernel locals namespaces prettyprint sequences +ui.frp vectors ; IN: file-trees TUPLE: tree node children ; -CONSULT: sequence-protocol tree children>> [ node>> ] map ; +CONSULT: sequence-protocol tree children>> ; : ( start -- tree ) V{ } clone [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ; @@ -20,4 +20,9 @@ DEFER: (tree-insert) path-rest [ path-head tree-insert ] unless-empty ] if* ; : create-tree ( file-list -- tree ) [ path-components ] map - t [ [ tree-insert ] curry each ] keep ; \ No newline at end of file + t [ [ tree-insert ] curry each ] keep ; + +: ( tree-model -- table ) + [ node>> 1array ] >>quot + [ selected-value>> ] + [ swap >>model ] bi ; \ No newline at end of file From 3e640e9cd6b3dfcd3c6171336b63fc1583d0d917 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 3 May 2009 15:30:37 -0500 Subject: [PATCH 46/58] add ${ to literals --- basis/literals/literals-tests.factor | 6 ++++++ basis/literals/literals.factor | 4 +++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor index 024c94e4f2..29072f1299 100644 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -19,3 +19,9 @@ IN: literals.tests [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test + +<< +CONSTANT: constant-a 3 +>> + +[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index e55d78ab6e..7c7592dda8 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,6 +1,8 @@ ! (c) Joe Groff, see license for details -USING: accessors continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations +combinators.smart vectors sequences ; IN: literals SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; +SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; From 6ccd82fabaac91923981a4b909db9ff428af5fce Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 15:52:26 -0500 Subject: [PATCH 47/58] world API changes: open-window can take a world-attributes tuple with additional parameters besides title. new begin-world, end-world, and draw-world* generics --- basis/ui/gadgets/worlds/worlds.factor | 63 +++++++++++++++++++-------- basis/ui/ui.factor | 23 ++++++++-- 2 files changed, 64 insertions(+), 22 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 171272dfc1..68ef6a4b9a 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -4,15 +4,27 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl opengl.textures sequences io combinators combinators.short-circuit fry math.vectors math.rectangles cache ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -ui.commands ui.pixel-formats destructors ; +ui.commands ui.pixel-formats destructors literals ; IN: ui.gadgets.worlds +CONSTANT: default-world-pixel-format-attributes + { windowed double-buffered T{ depth-bits { value 16 } } } + TUPLE: world < track -active? focused? -layers -title status status-owner -text-handle handle images -window-loc ; + active? focused? + layers + title status status-owner + text-handle handle images + window-loc + pixel-format-attributes ; + +TUPLE: world-attributes + { world-class initial: world } + title + status + gadgets + { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; +C: world-attributes : find-world ( gadget -- world/f ) [ world? ] find-parent ; @@ -45,18 +57,23 @@ M: world request-focus-on ( child gadget -- ) 2dup eq? [ 2drop ] [ dup focused?>> (request-focus) ] if ; -: new-world ( gadget title status class -- world ) +: new-world ( class -- world ) vertical swap new-track t >>root? t >>active? - { 0 0 } >>window-loc - swap >>status - swap >>title - swap 1 track-add - dup request-focus ; + { 0 0 } >>window-loc ; -: ( gadget title status -- world ) - world new-world ; +: apply-world-attributes ( world attributes -- world ) + { + [ title>> >>title ] + [ status>> >>status ] + [ pixel-format-attributes>> >>pixel-format-attributes ] + [ gadgets>> [ 1 track-add ] each ] + } cleave ; + +: ( world-attributes -- world ) + [ world-class>> new-world ] keep apply-world-attributes + dup request-focus ; : as-big-as-possible ( world gadget -- ) dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline @@ -77,7 +94,17 @@ SYMBOL: flush-layout-cache-hook flush-layout-cache-hook [ [ ] ] initialize -: (draw-world) ( world -- ) +GENERIC: begin-world ( world -- ) +GENERIC: end-world ( world -- ) + +M: world begin-world + drop ; +M: world end-world + drop ; + +GENERIC: draw-world* ( world -- ) + +M: world draw-world* dup handle>> [ check-extensions { @@ -108,7 +135,7 @@ ui-error-hook [ [ rethrow ] ] initialize : draw-world ( world -- ) dup draw-world? [ dup world [ - [ (draw-world) ] [ + [ draw-world* ] [ over ui-error f >>active? drop ] recover @@ -151,8 +178,7 @@ M: world handle-gesture ( gesture gadget -- ? ) [ get-global find-world eq? ] keep '[ f _ set-global ] when ; M: world world-pixel-format-attributes - drop - { windowed double-buffered T{ depth-bits { value 16 } } } ; + pixel-format-attributes>> ; M: world check-world-pixel-format 2drop ; @@ -160,3 +186,4 @@ M: world check-world-pixel-format : with-world-pixel-format ( world quot -- ) [ dup dup world-pixel-format-attributes ] dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline + diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 09403cb2d2..0d15d7d57a 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -4,7 +4,8 @@ USING: arrays assocs io kernel math models namespaces make dlists deques sequences threads sequences words continuations init combinators combinators.short-circuit hashtables concurrency.flags sets accessors calendar fry destructors ui.gadgets ui.gadgets.private -ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ; +ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render +strings ; IN: ui >focused? focus-path f swap focus-gestures ; -M: world graft* +: try-to-open-window ( world -- ) [ (open-window) ] + [ handle>> select-gl-context ] + [ + [ begin-world ] + [ [ handle>> (close-window) ] [ ui-error ] bi* ] + recover + ] tri ; + +M: world graft* + [ try-to-open-window ] [ [ title>> ] keep set-title ] [ request-focus ] tri ; @@ -66,6 +76,7 @@ M: world graft* [ images>> [ dispose ] when* ] [ hand-clicked close-global ] [ hand-gadget close-global ] + [ end-world ] } cleave ; M: world ungraft* @@ -166,13 +177,17 @@ PRIVATE> : restore-windows? ( -- ? ) windows get empty? not ; +: ?attributes ( gadget title/attributes -- attributes ) + dup string? [ world-attributes new swap >>title ] when + swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ; + PRIVATE> : open-world-window ( world -- ) dup pref-dim >>dim dup relayout graft ; -: open-window ( gadget title -- ) - f open-world-window ; +: open-window ( gadget title/attributes -- ) + ?attributes open-world-window ; : set-fullscreen? ( ? gadget -- ) find-world set-fullscreen* ; From cd87988ab31563e3a538a319365010b3f02ee0f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 3 May 2009 15:54:40 -0500 Subject: [PATCH 48/58] use ${ in a couple of places, use output>array --- basis/formatting/formatting.factor | 20 ++++++++++---------- basis/windows/errors/errors.factor | 14 ++++++++------ extra/spheres/spheres.factor | 16 +++++++++------- 3 files changed, 27 insertions(+), 23 deletions(-) diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index ac0b0850b4..5a517e4ac4 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -4,7 +4,7 @@ USING: accessors arrays ascii assocs calendar combinators fry kernel generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations -sequences splitting strings unicode.case vectors ; +sequences splitting strings unicode.case vectors combinators.smart ; IN: formatting @@ -113,7 +113,6 @@ MACRO: printf ( format-string -- ) : sprintf ( format-string -- result ) [ printf ] with-string-writer ; inline - string 2 CHAR: 0 pad-head ; inline @@ -129,12 +128,15 @@ MACRO: printf ( format-string -- ) [ pad-00 ] map "/" join ; inline : >datetime ( timestamp -- string ) - { [ day-of-week day-abbreviation3 ] - [ month>> month-abbreviation ] - [ day>> pad-00 ] - [ >time ] - [ year>> number>string ] - } cleave 5 narray " " join ; inline + [ + { + [ day-of-week day-abbreviation3 ] + [ month>> month-abbreviation ] + [ day>> pad-00 ] + [ >time ] + [ year>> number>string ] + } cleave + ] output>array " " join ; inline : (week-of-year) ( timestamp day -- n ) [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when @@ -187,5 +189,3 @@ PRIVATE> MACRO: strftime ( format-string -- ) parse-strftime [ length ] keep [ ] join '[ _ @ reverse concat nip ] ; - - diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index e08704d469..d180cb20e7 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,7 +1,7 @@ USING: alien.c-types kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays ; +arrays literals ; IN: windows.errors CONSTANT: ERROR_SUCCESS 0 @@ -732,11 +732,13 @@ ERROR: error-message-failed id ; win32-error-string throw ] when ; -: expected-io-errors ( -- seq ) - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT 4array ; foldable +CONSTANT: expected-io-errors + ${ + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT + } : expected-io-error? ( error-code -- ? ) expected-io-errors member? ; diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index fa666dd776..18e326f1b7 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,7 +1,7 @@ USING: kernel opengl opengl.demo-support opengl.gl opengl.textures opengl.shaders opengl.framebuffers opengl.capabilities multiline ui.gadgets accessors sequences ui.render ui math locals arrays -generalizations combinators ui.gadgets.worlds ; +generalizations combinators ui.gadgets.worlds literals ; IN: spheres STRING: plane-vertex-shader @@ -136,12 +136,14 @@ M: spheres-gadget distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri - GL_TEXTURE_CUBE_MAP_POSITIVE_X - GL_TEXTURE_CUBE_MAP_POSITIVE_Y - GL_TEXTURE_CUBE_MAP_POSITIVE_Z - GL_TEXTURE_CUBE_MAP_NEGATIVE_X - GL_TEXTURE_CUBE_MAP_NEGATIVE_Y - GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray + ${ + GL_TEXTURE_CUBE_MAP_POSITIVE_X + GL_TEXTURE_CUBE_MAP_POSITIVE_Y + GL_TEXTURE_CUBE_MAP_POSITIVE_Z + GL_TEXTURE_CUBE_MAP_NEGATIVE_X + GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + } [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each ] keep ; From 474735a60c349afea2cce0671162e143e2fe5538 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 17:11:01 -0500 Subject: [PATCH 49/58] update status-bar for api changes. set the gl-context outside of draw-world* generic --- basis/ui/gadgets/status-bar/status-bar.factor | 8 +++---- basis/ui/gadgets/worlds/worlds.factor | 22 +++++++++---------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/basis/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor index a1c2dca23d..0d3015508e 100644 --- a/basis/ui/gadgets/status-bar/status-bar.factor +++ b/basis/ui/gadgets/status-bar/status-bar.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors models models.delay models.arrow sequences ui.gadgets.labels ui.gadgets.tracks -ui.gadgets.worlds ui.gadgets ui kernel calendar summary ; +ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ; IN: ui.gadgets.status-bar : ( model -- gadget ) @@ -10,9 +10,9 @@ IN: ui.gadgets.status-bar reverse-video-theme t >>root? ; -: open-status-window ( gadget title -- ) - f [ ] keep - f track-add +: open-status-window ( gadget title/attributes -- ) + ?attributes f >>status + dup status>> f track-add open-world-window ; : show-summary ( object gadget -- ) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 68ef6a4b9a..837cf822dc 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -105,16 +105,13 @@ M: world end-world GENERIC: draw-world* ( world -- ) M: world draw-world* - dup handle>> [ - check-extensions - { - [ init-gl ] - [ draw-gadget ] - [ text-handle>> [ purge-cache ] when* ] - [ images>> [ purge-cache ] when* ] - } cleave - ] with-gl-context - flush-layout-cache-hook get call( -- ) ; + check-extensions + { + [ init-gl ] + [ draw-gadget ] + [ text-handle>> [ purge-cache ] when* ] + [ images>> [ purge-cache ] when* ] + } cleave ; : draw-world? ( world -- ? ) #! We don't draw deactivated worlds, or those with 0 size. @@ -135,7 +132,10 @@ ui-error-hook [ [ rethrow ] ] initialize : draw-world ( world -- ) dup draw-world? [ dup world [ - [ draw-world* ] [ + [ + dup handle>> [ draw-world* ] with-gl-context + flush-layout-cache-hook get call( -- ) + ] [ over ui-error f >>active? drop ] recover From 4e8df4a190729dc5125fa86893c82ca417352134 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 17:14:49 -0500 Subject: [PATCH 50/58] change spheres to use new world api --- extra/opengl/demo-support/demo-support.factor | 73 +++++++++---------- extra/spheres/spheres.factor | 60 ++++++++------- 2 files changed, 68 insertions(+), 65 deletions(-) diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 5973766c8e..4d5f5ee4b7 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,6 +1,6 @@ USING: arrays kernel math math.functions math.order math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures -ui.render accessors combinators ; +ui.gadgets.worlds ui.render accessors combinators ; IN: opengl.demo-support : FOV ( -- x ) 2.0 sqrt 1+ ; inline @@ -9,62 +9,61 @@ CONSTANT: KEY-ROTATE-STEP 10.0 SYMBOL: last-drag-loc -TUPLE: demo-gadget < gadget yaw pitch distance ; +TUPLE: demo-world < world yaw pitch distance ; -: new-demo-gadget ( yaw pitch distance class -- gadget ) - new - swap >>distance - swap >>pitch - swap >>yaw ; inline +: set-demo-orientation ( world yaw pitch distance -- world ) + [ >>yaw ] [ >>pitch ] [ >>distance ] tri* ; GENERIC: far-plane ( gadget -- z ) GENERIC: near-plane ( gadget -- z ) GENERIC: distance-step ( gadget -- dz ) -M: demo-gadget far-plane ( gadget -- z ) +M: demo-world far-plane ( gadget -- z ) drop 4.0 ; -M: demo-gadget near-plane ( gadget -- z ) +M: demo-world near-plane ( gadget -- z ) drop 1.0 64.0 / ; -M: demo-gadget distance-step ( gadget -- dz ) +M: demo-world distance-step ( gadget -- dz ) drop 1.0 64.0 / ; : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; -: yaw-demo-gadget ( yaw gadget -- ) +: yaw-demo-world ( yaw gadget -- ) [ + ] with change-yaw relayout-1 ; -: pitch-demo-gadget ( pitch gadget -- ) +: pitch-demo-world ( pitch gadget -- ) [ + ] with change-pitch relayout-1 ; -: zoom-demo-gadget ( distance gadget -- ) +: zoom-demo-world ( distance gadget -- ) [ + ] with change-distance relayout-1 ; -M: demo-gadget pref-dim* ( gadget -- dim ) +M: demo-world focusable-child* ( world -- gadget ) + drop t ; + +M: demo-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; : -+ ( x -- -x x ) [ neg ] keep ; -: demo-gadget-frustum ( gadget -- -x x -y y near far ) +: demo-world-frustum ( gadget -- -x x -y y near far ) [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ nip swap FOV / v*n first2 [ -+ ] bi@ ] 3keep drop ; -: demo-gadget-set-matrices ( gadget -- ) +M: demo-world begin-world + GL_PROJECTION glMatrixMode + glLoadIdentity + demo-world-frustum glFrustum ; + +: demo-world-set-matrix ( gadget -- ) GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - [ - GL_PROJECTION glMatrixMode - glLoadIdentity - demo-gadget-frustum glFrustum - ] [ - GL_MODELVIEW glMatrixMode - glLoadIdentity - [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ] - [ pitch>> 1.0 0.0 0.0 glRotatef ] - [ yaw>> 0.0 1.0 0.0 glRotatef ] - tri - ] bi ; + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ] + [ pitch>> 1.0 0.0 0.0 glRotatef ] + [ yaw>> 0.0 1.0 0.0 glRotatef ] + tri ; : reset-last-drag-rel ( -- ) { 0 0 } last-drag-loc set-global ; @@ -94,16 +93,16 @@ M: demo-gadget pref-dim* ( gadget -- dim ) swap first swap second glVertex2d ] do-state ; -demo-gadget H{ - { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] } - { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] } - { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] } - { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] } - { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] } - { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] } +demo-world H{ + { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-world ] } + { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-world ] } + { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-world ] } + { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-world ] } + { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-world ] } + { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-world ] } { T{ button-down f f 1 } [ drop reset-last-drag-rel ] } - { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] } - { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] } + { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] } + { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-world ] } } set-gestures diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index fa666dd776..708d6c68dd 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,7 +1,8 @@ USING: kernel opengl opengl.demo-support opengl.gl opengl.textures opengl.shaders opengl.framebuffers opengl.capabilities multiline ui.gadgets accessors sequences ui.render ui math locals arrays -generalizations combinators ui.gadgets.worlds ; +generalizations combinators ui.gadgets.worlds method-chains +literals ui.pixel-formats ; IN: spheres STRING: plane-vertex-shader @@ -110,19 +111,16 @@ main() } ; -TUPLE: spheres-gadget < demo-gadget +TUPLE: spheres-world < demo-world plane-program solid-sphere-program texture-sphere-program reflection-framebuffer reflection-depthbuffer - reflection-texture initialized? ; + reflection-texture ; -: ( -- gadget ) - 20.0 10.0 20.0 spheres-gadget new-demo-gadget ; - -M: spheres-gadget near-plane ( gadget -- z ) +M: spheres-world near-plane ( gadget -- z ) drop 1.0 ; -M: spheres-gadget far-plane ( gadget -- z ) +M: spheres-world far-plane ( gadget -- z ) drop 512.0 ; -M: spheres-gadget distance-step ( gadget -- dz ) +M: spheres-world distance-step ( gadget -- dz ) drop 0.5 ; : (reflection-dim) ( -- w h ) @@ -136,12 +134,14 @@ M: spheres-gadget distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri - GL_TEXTURE_CUBE_MAP_POSITIVE_X - GL_TEXTURE_CUBE_MAP_POSITIVE_Y - GL_TEXTURE_CUBE_MAP_POSITIVE_Z - GL_TEXTURE_CUBE_MAP_NEGATIVE_X - GL_TEXTURE_CUBE_MAP_NEGATIVE_Y - GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray + { + $ GL_TEXTURE_CUBE_MAP_POSITIVE_X + $ GL_TEXTURE_CUBE_MAP_POSITIVE_Y + $ GL_TEXTURE_CUBE_MAP_POSITIVE_Z + $ GL_TEXTURE_CUBE_MAP_NEGATIVE_X + $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + } [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each ] keep ; @@ -171,22 +171,19 @@ M: spheres-gadget distance-step ( gadget -- dz ) sphere-main-fragment-shader check-gl-shader 3array check-gl-program ; -M: spheres-gadget graft* ( gadget -- ) - dup find-gl-context +AFTER: spheres-world begin-world "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions { "GL_EXT_framebuffer_object" } require-gl-extensions + 20.0 10.0 20.0 set-demo-orientation (plane-program) >>plane-program (solid-sphere-program) >>solid-sphere-program (texture-sphere-program) >>texture-sphere-program (make-reflection-texture) >>reflection-texture (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep (make-reflection-framebuffer) >>reflection-framebuffer - t >>initialized? drop ; -M: spheres-gadget ungraft* ( gadget -- ) - f >>initialized? - dup find-gl-context +M: spheres-world end-world { [ reflection-framebuffer>> [ delete-framebuffer ] when* ] [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] @@ -196,7 +193,7 @@ M: spheres-gadget ungraft* ( gadget -- ) [ plane-program>> [ delete-gl-program ] when* ] } cleave ; -M: spheres-gadget pref-dim* ( gadget -- dim ) +M: spheres-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; :: (draw-sphere) ( program center radius -- ) @@ -280,12 +277,12 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) [ dim>> 0 0 rot first2 glViewport ] } cleave ] with-framebuffer ; -: (draw-gadget) ( gadget -- ) +M: spheres-world draw-world* GL_DEPTH_TEST glEnable GL_SCISSOR_TEST glDisable 0.15 0.15 1.0 1.0 glClearColor { [ (draw-reflection-texture) ] - [ demo-gadget-set-matrices ] + [ demo-world-set-matrix ] [ sphere-scene ] [ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ] [ @@ -297,10 +294,17 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) ] } cleave ; -M: spheres-gadget draw-gadget* ( gadget -- ) - dup initialized?>> [ (draw-gadget) ] [ drop ] if ; - : spheres-window ( -- ) - [ "Spheres" open-window ] with-ui ; + [ + f T{ world-attributes + { world-class spheres-world } + { title "Spheres" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 16 } } + } } + } open-window + ] with-ui ; MAIN: spheres-window From bc07c075e72bddfcf69cec4739ec54537c6408be Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 17:23:14 -0500 Subject: [PATCH 51/58] Merge branch 'master' of git://factorcode.org/git/factor Conflicts: extra/spheres/spheres.factor --- basis/formatting/formatting.factor | 20 ++++++++-------- basis/literals/literals-tests.factor | 6 +++++ basis/literals/literals.factor | 4 +++- basis/windows/errors/errors.factor | 14 ++++++----- extra/file-trees/file-trees.factor | 15 ++++++++---- extra/spheres/spheres.factor | 14 +++++------ extra/str-fry/str-fry.factor | 7 ++++-- extra/ui/frp/frp-docs.factor | 2 +- extra/ui/frp/frp.factor | 36 +++++++++++++++++++--------- 9 files changed, 75 insertions(+), 43 deletions(-) diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index ac0b0850b4..5a517e4ac4 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -4,7 +4,7 @@ USING: accessors arrays ascii assocs calendar combinators fry kernel generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations -sequences splitting strings unicode.case vectors ; +sequences splitting strings unicode.case vectors combinators.smart ; IN: formatting @@ -113,7 +113,6 @@ MACRO: printf ( format-string -- ) : sprintf ( format-string -- result ) [ printf ] with-string-writer ; inline - string 2 CHAR: 0 pad-head ; inline @@ -129,12 +128,15 @@ MACRO: printf ( format-string -- ) [ pad-00 ] map "/" join ; inline : >datetime ( timestamp -- string ) - { [ day-of-week day-abbreviation3 ] - [ month>> month-abbreviation ] - [ day>> pad-00 ] - [ >time ] - [ year>> number>string ] - } cleave 5 narray " " join ; inline + [ + { + [ day-of-week day-abbreviation3 ] + [ month>> month-abbreviation ] + [ day>> pad-00 ] + [ >time ] + [ year>> number>string ] + } cleave + ] output>array " " join ; inline : (week-of-year) ( timestamp day -- n ) [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when @@ -187,5 +189,3 @@ PRIVATE> MACRO: strftime ( format-string -- ) parse-strftime [ length ] keep [ ] join '[ _ @ reverse concat nip ] ; - - diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor index 024c94e4f2..29072f1299 100644 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -19,3 +19,9 @@ IN: literals.tests [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test + +<< +CONSTANT: constant-a 3 +>> + +[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index e55d78ab6e..7c7592dda8 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -1,6 +1,8 @@ ! (c) Joe Groff, see license for details -USING: accessors continuations kernel parser words quotations vectors ; +USING: accessors continuations kernel parser words quotations +combinators.smart vectors sequences ; IN: literals SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ; SYNTAX: $[ parse-quotation with-datastack >vector ; +SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ; diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index e08704d469..d180cb20e7 100644 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,7 +1,7 @@ USING: alien.c-types kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays ; +arrays literals ; IN: windows.errors CONSTANT: ERROR_SUCCESS 0 @@ -732,11 +732,13 @@ ERROR: error-message-failed id ; win32-error-string throw ] when ; -: expected-io-errors ( -- seq ) - ERROR_SUCCESS - ERROR_IO_INCOMPLETE - ERROR_IO_PENDING - WAIT_TIMEOUT 4array ; foldable +CONSTANT: expected-io-errors + ${ + ERROR_SUCCESS + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + WAIT_TIMEOUT + } : expected-io-error? ( error-code -- ? ) expected-io-errors member? ; diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor index 788291c0a2..eadfccdc4c 100644 --- a/extra/file-trees/file-trees.factor +++ b/extra/file-trees/file-trees.factor @@ -1,10 +1,10 @@ -USING: accessors delegate delegate.protocols io.pathnames -kernel locals namespaces sequences vectors -tools.annotations prettyprint ; +USING: accessors arrays delegate delegate.protocols +io.pathnames kernel locals namespaces prettyprint sequences +ui.frp vectors ; IN: file-trees TUPLE: tree node children ; -CONSULT: sequence-protocol tree children>> [ node>> ] map ; +CONSULT: sequence-protocol tree children>> ; : ( start -- tree ) V{ } clone [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ; @@ -20,4 +20,9 @@ DEFER: (tree-insert) path-rest [ path-head tree-insert ] unless-empty ] if* ; : create-tree ( file-list -- tree ) [ path-components ] map - t [ [ tree-insert ] curry each ] keep ; \ No newline at end of file + t [ [ tree-insert ] curry each ] keep ; + +: ( tree-model -- table ) + [ node>> 1array ] >>quot + [ selected-value>> ] + [ swap >>model ] bi ; \ No newline at end of file diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 708d6c68dd..671edf38ce 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -134,13 +134,13 @@ M: spheres-world distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri - { - $ GL_TEXTURE_CUBE_MAP_POSITIVE_X - $ GL_TEXTURE_CUBE_MAP_POSITIVE_Y - $ GL_TEXTURE_CUBE_MAP_POSITIVE_Z - $ GL_TEXTURE_CUBE_MAP_NEGATIVE_X - $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y - $ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z + ${ + GL_TEXTURE_CUBE_MAP_POSITIVE_X + GL_TEXTURE_CUBE_MAP_POSITIVE_Y + GL_TEXTURE_CUBE_MAP_POSITIVE_Z + GL_TEXTURE_CUBE_MAP_NEGATIVE_X + GL_TEXTURE_CUBE_MAP_NEGATIVE_Y + GL_TEXTURE_CUBE_MAP_NEGATIVE_Z } [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor index aafdaa95d9..bfe74f37eb 100644 --- a/extra/str-fry/str-fry.factor +++ b/extra/str-fry/str-fry.factor @@ -1,4 +1,7 @@ -USING: kernel sequences splitting strings.parser ; +USING: combinators effects kernel math sequences splitting +strings.parser ; IN: str-fry -: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ; +: str-fry ( str -- quot ) "_" split + [ unclip [ [ rot glue ] reduce ] 2curry ] + [ length 1 - 1 [ call-effect ] 2curry ] bi ; SYNTAX: I" parse-string rest str-fry over push-all ; \ No newline at end of file diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor index af44567e46..479a56e513 100644 --- a/extra/ui/frp/frp-docs.factor +++ b/extra/ui/frp/frp-docs.factor @@ -36,7 +36,7 @@ HELP: { $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } } { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ; -HELP: switch +HELP: { $values { "signal1" model } { "signal2" model } { "signal'" model } } { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ; diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor index aa7c44ee03..699d034c72 100644 --- a/extra/ui/frp/frp.factor +++ b/extra/ui/frp/frp.factor @@ -1,7 +1,7 @@ -USING: accessors arrays colors fonts fry kernel models +USING: accessors arrays colors fonts kernel models models.product monads sequences ui.gadgets ui.gadgets.buttons ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables -ui.gadgets.tracks ui.render ; +ui.gadgets.tracks ui.render ui.gadgets.scrollers ; QUALIFIED: make IN: ui.frp @@ -18,8 +18,11 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model f >>selected-value sans-serif-font >>font focus-border-color >>focus-border-color - transparent >>column-line-color ; + transparent >>column-line-color [ ] >>val-quot ; +: ( -- table ) f ; : ( model -- table ) [ 1array ] >>quot ; +: ( -- table ) f ; + : ( -- field ) f ; ! Layout utilities @@ -27,6 +30,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ; GENERIC: output-model ( gadget -- model ) M: gadget output-model model>> ; M: frp-table output-model selected-value>> ; +M: model-field output-model field-model>> ; +M: scroller output-model children>> first model>> ; GENERIC: , ( uiitem -- ) M: gadget , make:, ; @@ -41,13 +46,16 @@ M: table -> dup , selected-value>> ; [ { } make:make ] dip swap [ f track-add ] each ; inline : ( gadgets type -- track ) [ ] [ [ model>> ] map ] bi >>model ; inline : ( gadgets -- track ) horizontal ; inline +: ( gadgets -- track ) horizontal ; inline : ( gadgets -- track ) vertical ; inline +: ( gadgets -- track ) vertical ; inline -! Model utilities +! !!! Model utilities TUPLE: multi-model < model ; -! M: multi-model model-activated dup model-changed ; : ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ; +! Events- discrete model utilities + TUPLE: merge-model < multi-model ; M: merge-model model-changed [ value>> ] dip set-model ; : ( models -- model ) merge-model ; @@ -57,15 +65,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke [ set-model ] [ 2drop ] if ; : ( model quot -- filter-model ) [ 1array filter-model ] dip >>quot ; +! Behaviors - continuous model utilities + TUPLE: fold-model < multi-model oldval quot ; M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ; -: ( oldval quot model -- model' ) 1array fold-model swap >>quot swap >>oldval ; +: ( oldval quot model -- model' ) 1array fold-model swap >>quot + swap [ >>oldval ] [ >>value ] bi ; -TUPLE: switch-model < multi-model switcher on ; -M: switch-model model-changed tuck [ switcher>> = ] 2keep - '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ; -: switch ( signal1 signal2 -- signal' ) [ 2array switch-model ] keep >>switcher ; +TUPLE: switch-model < multi-model original switcher on ; +M: switch-model model-changed 2dup switcher>> = + [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ] + [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ; +M: switch-model model-activated [ original>> ] keep model-changed ; +: ( signal1 signal2 -- signal' ) [ 2array switch-model ] 2keep + [ >>original ] [ >>switcher ] bi* ; TUPLE: mapped < model model quot ; @@ -87,4 +101,4 @@ INSTANCE: gadget-monad monad INSTANCE: gadget monad M: gadget monad-of drop gadget-monad ; M: gadget-monad return drop swap >>model ; -M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; \ No newline at end of file +M: gadget >>= output-model [ swap call( x -- y ) ] curry ; \ No newline at end of file From 585ea8da544bba0da0161ebd4ff0382d5ed4b0c9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 18:32:35 -0500 Subject: [PATCH 52/58] don't pprint gadgets with RECT: syntax --- basis/prettyprint/backend/backend.factor | 7 +++++-- basis/ui/gadgets/gadgets.factor | 6 +++++- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 1976c84fd1..22dec9d2fc 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -135,8 +135,8 @@ M: pathname pprint* [ text ] [ f ] bi* \ } pprint-word block> ; -M: tuple pprint* - boa-tuples? get [ call-next-method ] [ +: pprint-tuple ( tuple -- ) + boa-tuples? get [ pprint-object ] [ [ > ; From 045635cdf26c620903e481bf84c24d1702f6510b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 20:33:03 -0500 Subject: [PATCH 53/58] yield during mouse-moved events in cocoa so gadgets have a chance to redraw --- basis/ui/backend/cocoa/views/views.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index 4a16e3bd37..aab851c783 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -9,7 +9,7 @@ threads combinators math.rectangles ; IN: ui.backend.cocoa.views : send-mouse-moved ( view event -- ) - [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ; + [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ; : button ( event -- n ) #! Cocoa -> Factor UI button mapping From 45049077360d81c4d707c8f5d281f465dd18748a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 22:01:35 -0500 Subject: [PATCH 54/58] add a resize-world generic to handle window resizes --- basis/ui/gadgets/worlds/worlds.factor | 13 +++++++++++++ basis/ui/ui.factor | 17 ++++++++++------- 2 files changed, 23 insertions(+), 7 deletions(-) diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 837cf822dc..31b5a137a3 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -24,6 +24,7 @@ TUPLE: world-attributes status gadgets { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ; + C: world-attributes : find-world ( gadget -- world/f ) [ world? ] find-parent ; @@ -97,10 +98,22 @@ flush-layout-cache-hook [ [ ] ] initialize GENERIC: begin-world ( world -- ) GENERIC: end-world ( world -- ) +GENERIC: resize-world ( world -- ) + M: world begin-world drop ; M: world end-world drop ; +M: world resize-world + drop ; + +M: world (>>dim) + [ call-next-method ] + [ + dup handle>> + [ select-gl-context resize-world ] + [ drop ] if* + ] bi ; GENERIC: draw-world* ( world -- ) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 0d15d7d57a..d07403836a 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -51,13 +51,16 @@ SYMBOL: windows focus-path f swap focus-gestures ; : try-to-open-window ( world -- ) - [ (open-window) ] - [ handle>> select-gl-context ] - [ - [ begin-world ] - [ [ handle>> (close-window) ] [ ui-error ] bi* ] - recover - ] tri ; + { + [ (open-window) ] + [ handle>> select-gl-context ] + [ + [ begin-world ] + [ [ handle>> (close-window) ] [ ui-error ] bi* ] + recover + ] + [ resize-world ] + } cleave ; M: world graft* [ try-to-open-window ] From 8925773558007aee490170d73eb15ec746e76c7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 22:02:50 -0500 Subject: [PATCH 55/58] update bunny to use world api; clean up projection matrix and viewport discipline in demos --- extra/bunny/bunny.factor | 53 +++++++++++-------- extra/bunny/outlined/outlined.factor | 10 +++- extra/opengl/demo-support/demo-support.factor | 7 +-- extra/spheres/spheres.factor | 10 ++-- 4 files changed, 50 insertions(+), 30 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index d0625e464f..620f737fe3 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,58 +1,67 @@ USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline bunny.model bunny.outlined destructors kernel math opengl.demo-support opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures -ui.render words ; +ui.render words ui.pixel-formats ; IN: bunny -TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ; +TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ; -: ( -- bunny-gadget ) - 0.0 0.0 0.375 bunny-gadget new-demo-gadget - maybe-download read-model >>model-triangles ; - -: bunny-gadget-draw ( gadget -- draw ) +: get-draw ( gadget -- draw ) [ draw-n>> ] [ draw-seq>> ] bi nth ; -: bunny-gadget-next-draw ( gadget -- ) +: next-draw ( gadget -- ) dup [ draw-seq>> ] [ draw-n>> ] bi 1+ swap length mod >>draw-n relayout-1 ; -M: bunny-gadget graft* ( gadget -- ) - dup find-gl-context - GL_DEPTH_TEST glEnable - dup model-triangles>> >>geom - dup +: make-draws ( gadget -- draw-seq ) [ ] [ ] [ ] tri 3array - sift >>draw-seq + sift ; + +M: bunny-world begin-world + GL_DEPTH_TEST glEnable + 0.0 0.0 0.375 set-demo-orientation + maybe-download read-model + [ >>model-triangles ] [ >>geom ] bi + dup make-draws >>draw-seq 0 >>draw-n drop ; -M: bunny-gadget ungraft* ( gadget -- ) +M: bunny-world end-world dup find-gl-context [ geom>> [ dispose ] when* ] [ draw-seq>> [ [ dispose ] when* ] each ] bi ; -M: bunny-gadget draw-gadget* ( gadget -- ) +M: bunny-world draw-world* dup draw-seq>> empty? [ drop ] [ 0.15 0.15 0.15 1.0 glClearColor GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear - dup demo-gadget-set-matrices + dup demo-world-set-matrix GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny + [ geom>> ] [ get-draw ] bi draw-bunny ] if ; -M: bunny-gadget pref-dim* ( gadget -- dim ) +M: bunny-world pref-dim* ( gadget -- dim ) drop { 640 480 } ; -bunny-gadget H{ - { T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] } +bunny-world H{ + { T{ key-down f f "TAB" } [ next-draw ] } } set-gestures : bunny-window ( -- ) - [ "Bunny" open-window ] with-ui ; + [ + f T{ world-attributes + { world-class bunny-world } + { title "Bunny" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 16 } } + } } + } open-window + ] with-ui ; MAIN: bunny-window diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 7491ed8bcb..0ad2a72100 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -216,7 +216,11 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- ) ] with-framebuffer ; : (pass2) ( draw -- ) - init-matrices { + GL_PROJECTION glMatrixMode + glPushMatrix glLoadIdentity + GL_MODELVIEW glMatrixMode + glLoadIdentity + { [ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ] [ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ] @@ -230,7 +234,9 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- ) } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ] - } cleave ; + } cleave + GL_PROJECTION glMatrixMode + glPopMatrix ; M: bunny-outlined draw-bunny [ remake-framebuffer-if-needed ] diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 4d5f5ee4b7..35c64d4ad1 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -45,16 +45,17 @@ M: demo-world pref-dim* ( gadget -- dim ) : -+ ( x -- -x x ) [ neg ] keep ; -: demo-world-frustum ( gadget -- -x x -y y near far ) +: demo-world-frustum ( world -- -x x -y y near far ) [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ nip swap FOV / v*n first2 [ -+ ] bi@ ] 3keep drop ; -M: demo-world begin-world +M: demo-world resize-world GL_PROJECTION glMatrixMode glLoadIdentity - demo-world-frustum glFrustum ; + [ [ 0 0 ] dip dim>> first2 glViewport ] + [ demo-world-frustum glFrustum ] bi ; : demo-world-set-matrix ( gadget -- ) GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 671edf38ce..d763e476be 100755 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -171,7 +171,7 @@ M: spheres-world distance-step ( gadget -- dz ) sphere-main-fragment-shader check-gl-shader 3array check-gl-program ; -AFTER: spheres-world begin-world +M: spheres-world begin-world "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions { "GL_EXT_framebuffer_object" } require-gl-extensions 20.0 10.0 20.0 set-demo-orientation @@ -251,7 +251,7 @@ M: spheres-world pref-dim* ( gadget -- dim ) [ drop 0 0 (reflection-dim) glViewport ] [ GL_PROJECTION glMatrixMode - glLoadIdentity + glPushMatrix glLoadIdentity reflection-frustum glFrustum GL_MODELVIEW glMatrixMode glLoadIdentity @@ -274,7 +274,11 @@ M: spheres-world pref-dim* ( gadget -- dim ) [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face) glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ] [ sphere-scene ] - [ dim>> 0 0 rot first2 glViewport ] + [ + [ 0 0 ] dip dim>> first2 glViewport + GL_PROJECTION glMatrixMode + glPopMatrix + ] } cleave ] with-framebuffer ; M: spheres-world draw-world* From fa8c47d310fc6ae0ea4e684f43b1f001c1901d69 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 22:04:25 -0500 Subject: [PATCH 56/58] move ui.offscreen to unmaintained for now --- {extra => unmaintained}/ui/offscreen/authors.txt | 0 {extra => unmaintained}/ui/offscreen/offscreen-docs.factor | 0 {extra => unmaintained}/ui/offscreen/offscreen.factor | 0 {extra => unmaintained}/ui/offscreen/summary.txt | 0 {extra => unmaintained}/ui/offscreen/tags.txt | 0 5 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/ui/offscreen/authors.txt (100%) rename {extra => unmaintained}/ui/offscreen/offscreen-docs.factor (100%) rename {extra => unmaintained}/ui/offscreen/offscreen.factor (100%) rename {extra => unmaintained}/ui/offscreen/summary.txt (100%) rename {extra => unmaintained}/ui/offscreen/tags.txt (100%) diff --git a/extra/ui/offscreen/authors.txt b/unmaintained/ui/offscreen/authors.txt similarity index 100% rename from extra/ui/offscreen/authors.txt rename to unmaintained/ui/offscreen/authors.txt diff --git a/extra/ui/offscreen/offscreen-docs.factor b/unmaintained/ui/offscreen/offscreen-docs.factor similarity index 100% rename from extra/ui/offscreen/offscreen-docs.factor rename to unmaintained/ui/offscreen/offscreen-docs.factor diff --git a/extra/ui/offscreen/offscreen.factor b/unmaintained/ui/offscreen/offscreen.factor similarity index 100% rename from extra/ui/offscreen/offscreen.factor rename to unmaintained/ui/offscreen/offscreen.factor diff --git a/extra/ui/offscreen/summary.txt b/unmaintained/ui/offscreen/summary.txt similarity index 100% rename from extra/ui/offscreen/summary.txt rename to unmaintained/ui/offscreen/summary.txt diff --git a/extra/ui/offscreen/tags.txt b/unmaintained/ui/offscreen/tags.txt similarity index 100% rename from extra/ui/offscreen/tags.txt rename to unmaintained/ui/offscreen/tags.txt From d546e8c89aed1ad2762bc225f958c2a77e12b338 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 22:21:36 -0500 Subject: [PATCH 57/58] nitpick ui.pixel-formats docs --- basis/ui/pixel-formats/pixel-formats-docs.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor index 207b757908..003b205c3d 100644 --- a/basis/ui/pixel-formats/pixel-formats-docs.factor +++ b/basis/ui/pixel-formats/pixel-formats-docs.factor @@ -91,29 +91,29 @@ HELP: backing-store { double-buffered backing-store } related-words HELP: multisampled -{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of multisampling." } +{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of multisampling." } { $notes "On some window systems this is not distinct from " { $link supersampled } "." } ; HELP: supersampled -{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of supersampling." } +{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of supersampling." } { $notes "On some window systems this is not distinct from " { $link multisampled } "." } ; HELP: sample-alpha { $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ; HELP: color-float -{ $class-description "Requests a pixel format where the pixels are stored in floating-point format." } ; +{ $class-description "Requests a pixel format where the color buffer is stored in floating-point format." } ; HELP: color-bits -{ $class-description "Requests a pixel format of at least " { $snippet "value" } " bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer of at least " { $snippet "value" } " bits per pixel." } ; HELP: red-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " red bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " red bits per pixel." } ; HELP: green-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " green bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " green bits per pixel." } ; HELP: blue-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " blue bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ; HELP: alpha-bits -{ $class-description "Requests a pixel format with at least " { $snippet "value" } " alpha bits per pixel." } ; +{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " alpha bits per pixel." } ; { color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words From 804d4aae81204a08671e7eb20e567f18559c045a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 May 2009 23:01:26 -0500 Subject: [PATCH 58/58] docs for new world words --- .../gadgets/status-bar/status-bar-docs.factor | 4 +-- basis/ui/gadgets/worlds/worlds-docs.factor | 31 +++++++++++++++++-- basis/ui/ui-docs.factor | 19 +++++++++--- 3 files changed, 45 insertions(+), 9 deletions(-) diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor index 57c69c2a66..7a68310e36 100644 --- a/basis/ui/gadgets/status-bar/status-bar-docs.factor +++ b/basis/ui/gadgets/status-bar/status-bar-docs.factor @@ -18,7 +18,7 @@ HELP: { $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ; HELP: open-status-window -{ $values { "gadget" gadget } { "title" string } } +{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } } { $description "Like " { $link open-window } ", with the additional feature that the new window iwll have a status bar displaying the value stored in the world's " { $slot "status" } " slot." } { $see-also show-status hide-status } ; @@ -30,4 +30,4 @@ ARTICLE: "ui.gadgets.status-bar" "Status bars and mouse-over help" { $subsection hide-status } { $link "ui.gadgets.presentations" } " use the status bar to display object summary." ; -ABOUT: "ui.gadgets.status-bar" \ No newline at end of file +ABOUT: "ui.gadgets.status-bar" diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor index 9d4df189f2..d4e9790d89 100755 --- a/basis/ui/gadgets/worlds/worlds-docs.factor +++ b/basis/ui/gadgets/worlds/worlds-docs.factor @@ -48,8 +48,8 @@ HELP: world } ; HELP: -{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } } -{ $description "Creates a new " { $link world } " delegating to the given gadget." } ; +{ $values { "world-attributes" world-attributes } { "world" "a new " { $link world } } } +{ $description "Creates a new " { $link world } " or world subclass with the given attributes." } ; HELP: find-world { $values { "gadget" gadget } { "world/f" { $maybe world } } } @@ -65,6 +65,30 @@ HELP: find-gl-context { $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." } { $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ; +HELP: begin-world +{ $values { "world" world } } +{ $description "Called immediately after " { $snippet "world" } "'s OpenGL context has been created. The world's OpenGL context is current when this method is called." } ; + +HELP: end-world +{ $values { "world" world } } +{ $description "Called immediately before " { $snippet "world" } "'s OpenGL context is destroyed. The world's OpenGL context is current when this method is called." } ; + +HELP: resize-world +{ $values { "world" world } } +{ $description "Called when the window containing " { $snippet "world" } " is resized. The " { $snippet "loc" } " and " { $snippet "dim" } " slots of " { $snippet "world" } " will be updated with the world's new position and size. The world's OpenGL context is current when this method is called." } ; + +HELP: draw-world* +{ $values { "world" world } } +{ $description "Called when " { $snippet "world" } " needs to be redrawn. The world's OpenGL context is current when this method is called." } ; + +ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds" +"The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:" +{ $subsection begin-world } +{ $subsection end-world } +{ $subsection resize-world } +{ $subsection draw-world* } +"See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ; + ARTICLE: "ui-paint-custom" "Implementing custom drawing logic" "The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:" { $subsection draw-gadget* } @@ -72,7 +96,8 @@ ARTICLE: "ui-paint-custom" "Implementing custom drawing logic" $nl "Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:" { $subsection find-gl-context } -"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa." +"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "." { $subsection "ui-paint-coord" } +{ $subsection "ui.gadgets.worlds-subclassing" } { $subsection "gl-utilities" } { $subsection "text-rendering" } ; diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index f2b6154745..397fc419fa 100644 --- a/basis/ui/ui-docs.factor +++ b/basis/ui/ui-docs.factor @@ -2,17 +2,28 @@ USING: help.markup help.syntax strings quotations debugger namespaces ui.backend ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ui.gadgets.private math.rectangles colors ui.text fonts -kernel ui.private ; +kernel ui.private classes sequences ; IN: ui HELP: windows { $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ; -{ windows open-window find-window } related-words +{ windows open-window find-window world-attributes } related-words HELP: open-window -{ $values { "gadget" gadget } { "title" string } } -{ $description "Opens a native window with the specified title." } ; +{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } } +{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ; + +HELP: world-attributes +{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } } +{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" } +{ $list + { { $snippet "world-class" } " specifies the class of world to construct. " { $link world } " is the default." } + { { $snippet "title" } " is the window title." } + { { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." } + { { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." } + { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." } +} ; HELP: set-fullscreen? { $values { "?" "a boolean" } { "gadget" gadget } }