From 5d6720f9916e7d1ada9bad5b38a0802368f6edca Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 21 Mar 2008 20:36:24 -0700 Subject: [PATCH 01/14] Unit tests for COM callbacks --- extra/windows/com/com-tests.factor | 162 ++++++++++++----------------- 1 file changed, 69 insertions(+), 93 deletions(-) diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor index 4a2f465fef..4c62e7adfd 100644 --- a/extra/windows/com/com-tests.factor +++ b/extra/windows/com/com-tests.factor @@ -1,93 +1,69 @@ -USING: kernel windows.com windows.com.syntax windows.ole32 -alien alien.syntax tools.test libc alien.c-types arrays.lib -namespaces arrays continuations ; -IN: windows.com.tests - -! Create some test COM interfaces - -COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} - HRESULT returnOK ( ) - HRESULT returnError ( ) ; - -COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} - int getX ( ) - void setX ( int newX ) ; - -! Implement the IInherited interface in factor using alien-callbacks - -C-STRUCT: test-implementation - { "void*" "vtbl" } - { "int" "x" } ; - -: QueryInterface-callback - "HRESULT" { "void*" "REFGUID" "void**" } "stdcall" [ nip 0 swap set-void*-nth S_OK ] - alien-callback ; -: AddRef-callback - "ULONG" { "void*" } "stdcall" [ drop 2 ] - alien-callback ; -: Release-callback - "ULONG" { "void*" } "stdcall" [ drop 1 ] - alien-callback ; -: returnOK-callback - "HRESULT" { "void*" } "stdcall" [ drop S_OK ] - alien-callback ; -: returnError-callback - "HRESULT" { "void*" } "stdcall" [ drop E_FAIL ] - alien-callback ; -: getX-callback - "int" { "void*" } "stdcall" [ test-implementation-x ] - alien-callback ; -: setX-callback - "void" { "void*" "int" } "stdcall" [ swap set-test-implementation-x ] - alien-callback ; - -SYMBOL: +test-implementation-vtbl+ -SYMBOL: +guinea-pig-implementation+ - -: (make-test-implementation) ( x imp -- imp ) - [ set-test-implementation-x ] keep - +test-implementation-vtbl+ get over set-test-implementation-vtbl ; - -: ( x -- imp ) - "test-implementation" (make-test-implementation) ; - -: ( x -- imp ) - "test-implementation" heap-size malloc (make-test-implementation) ; - -QueryInterface-callback -AddRef-callback -Release-callback -returnOK-callback -returnError-callback -getX-callback -setX-callback -7 narray >c-void*-array -dup byte-length [ - [ byte-array>memory ] keep - +test-implementation-vtbl+ set - - ! Test that the words defined by COM-INTERFACE: do their magic - - "{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test - "{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test - "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test - S_OK 1array [ 0 ISimple::returnOK ] unit-test - E_FAIL *long 1array [ 0 ISimple::returnError ] unit-test - 1984 1array [ 0 dup 1984 IInherited::setX IInherited::getX ] unit-test - - ! Test that the helper functions for QueryInterface, AddRef, Release work - - 0 +guinea-pig-implementation+ set - [ - +guinea-pig-implementation+ get 1array [ - +guinea-pig-implementation+ get com-add-ref - ] unit-test - - { } [ +guinea-pig-implementation+ get com-release ] unit-test - - +guinea-pig-implementation+ get 1array [ - +guinea-pig-implementation+ get IUnknown-iid com-query-interface - ] unit-test - - ] [ +guinea-pig-implementation+ get free ] [ ] cleanup -] with-malloc +USING: kernel windows.com windows.com.syntax windows.ole32 +alien alien.syntax tools.test libc alien.c-types arrays.lib +namespaces arrays continuations accessors ; +IN: windows.com.tests + +COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} + HRESULT returnOK ( ) + HRESULT returnError ( ) ; + +COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} + int getX ( ) + void setX ( int newX ) ; + +COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} + int xPlus ( int y ) + int xMulAdd ( int mul, int add ) ; + +"{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test +"{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test +"{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test + +SYMBOL: +test-vtbl+ +SYMBOL: +guinea-pig-implementation+ + +TUPLE: test-implementation x ; +C: test-implementation + +{ + { "IInherited" { + [ drop S_OK ] ! ISimple::returnOK + [ drop E_FAIL ] ! ISimple::returnError + [ x>> ] ! IInherited::getX + [ >>x drop ] ! IInherited::setX + } } + { "IUnrelated" { + [ swap x>> + ] ! IUnrelated::xPlus + [ spin x>> * + ] ! IUnrealted::xMulAdd + } } +} +dup +test-vtbl+ set [ + + 0 +test-vtbl+ get com-wrap + dup +guinea-pig-implementation+ set [ + + S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test + E_FAIL *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test + 20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test + 420 1array [ +guinea-pig-implementation+ get 20 20 IUnrelated::xMulAdd ] unit-test + 40 1array [ +guinea-pig-implementation+ get 20 IUnrelated::xPlus ] unit-test + + +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get com-add-ref + ] unit-test + + { } [ +guinea-pig-implementation+ get com-release ] unit-test + + +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get IUnknown-iid com-query-interface + ] unit-test + +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get ISimple-iid com-query-interface + ] unit-test + "void*" heap-size +guinea-pig-implementation+ get 1array [ + +guinea-pig-implementation+ get IUnrelated-iid com-query-interface + ] unit-test + + ] with-com-interface + +] [ free-com-vtbl ] [ ] cleanup From f2718f3a71fdb89d49e7a6aa46041ddecc5ff3d7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 31 Mar 2008 12:31:46 -0700 Subject: [PATCH 02/14] Get COM wrappers working. dragdrop-listener example vocab to enable drag-and-drop on listener windows --- core/slots/slots-docs.factor | 2 +- extra/windows/com/com-docs.factor | 2 +- extra/windows/com/com-tests.factor | 44 +++++-- extra/windows/com/com.factor | 23 +++- extra/windows/com/syntax/syntax.factor | 10 +- extra/windows/com/wrapper/wrapper-docs.factor | 40 +++++++ extra/windows/com/wrapper/wrapper.factor | 111 ++++++++++++++++++ .../dragdrop-listener.factor | 70 +++++++++++ extra/windows/kernel32/kernel32.factor | 5 +- extra/windows/ole32/ole32.factor | 96 +++++++++++++-- extra/windows/shell32/shell32.factor | 14 ++- extra/windows/time/time.factor | 0 12 files changed, 386 insertions(+), 31 deletions(-) create mode 100755 extra/windows/com/wrapper/wrapper-docs.factor create mode 100755 extra/windows/com/wrapper/wrapper.factor create mode 100644 extra/windows/dragdrop-listener/dragdrop-listener.factor mode change 100755 => 100644 extra/windows/time/time.factor diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index e4bb307829..5de765313b 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -12,7 +12,7 @@ ARTICLE: "accessors" "Slot accessors" } "In addition, two utility words are defined for each distinct slot name used in the system:" { $list - { "The " { $emphasis "setter" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." } + { "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." } { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." } } "Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names." diff --git a/extra/windows/com/com-docs.factor b/extra/windows/com/com-docs.factor index 901a88675f..68663b4cdb 100644 --- a/extra/windows/com/com-docs.factor +++ b/extra/windows/com/com-docs.factor @@ -4,7 +4,7 @@ IN: windows.com HELP: com-query-interface { $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } { "iid" "An interface GUID (IID)" } { "interface'" "Pointer to a COM interface implementing the interface indicated by " { $snippet "iid" } } } -{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be immediately retained using " { $link com-add-ref } ". The pointer must then be released using " { $link com-release } " when it is no longer needed." } ; +{ $description "A small wrapper around " { $link IUnknown::QueryInterface } ". Queries " { $snippet "interface" } " to see if it implements the interface indicated by " { $snippet "iid" } ". Returns a pointer to the " { $snippet "iid" } " interface if implemented, or raises an error if the object does not implement the interface.\n\nCOM memory management conventions state that the returned pointer must be released using " { $link com-release } " when it is no longer needed." } ; HELP: com-add-ref { $values { "interface" "Pointer to a COM interface implementing " { $snippet "IUnknown" } } } diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor index 4c62e7adfd..e2685db1d0 100644 --- a/extra/windows/com/com-tests.factor +++ b/extra/windows/com/com-tests.factor @@ -1,6 +1,7 @@ USING: kernel windows.com windows.com.syntax windows.ole32 alien alien.syntax tools.test libc alien.c-types arrays.lib -namespaces arrays continuations accessors ; +namespaces arrays continuations accessors math windows.com.wrapper +windows.com.wrapper.private ; IN: windows.com.tests COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} @@ -18,12 +19,16 @@ COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} "{216fb341-0eb2-44b1-8edb-60b76e353abc}" string>guid 1array [ ISimple-iid ] unit-test "{9620ecec-8438-423b-bb14-86f835aa40dd}" string>guid 1array [ IInherited-iid ] unit-test "{00000000-0000-0000-C000-000000000046}" string>guid 1array [ IUnknown-iid ] unit-test +"{b06ac3f4-30e4-406b-a7cd-c29cead4552c}" string>guid 1array [ IUnrelated-iid ] unit-test -SYMBOL: +test-vtbl+ +SYMBOL: +test-wrapper+ SYMBOL: +guinea-pig-implementation+ +SYMBOL: +orig-wrapped-objects+ + ++wrapped-objects+ get-global clone +orig-wrapped-objects+ set-global TUPLE: test-implementation x ; -C: test-implementation +C: test-implementation { { "IInherited" { @@ -36,17 +41,25 @@ C: test-implementation [ swap x>> + ] ! IUnrelated::xPlus [ spin x>> * + ] ! IUnrealted::xMulAdd } } -} -dup +test-vtbl+ set [ +} +dup +test-wrapper+ set [ - 0 +test-vtbl+ get com-wrap - dup +guinea-pig-implementation+ set [ + 0 swap com-wrap + dup +guinea-pig-implementation+ set [ drop S_OK 1array [ +guinea-pig-implementation+ get ISimple::returnOK ] unit-test E_FAIL *long 1array [ +guinea-pig-implementation+ get ISimple::returnError ] unit-test 20 1array [ +guinea-pig-implementation+ get dup 20 IInherited::setX IInherited::getX ] unit-test - 420 1array [ +guinea-pig-implementation+ get 20 20 IUnrelated::xMulAdd ] unit-test - 40 1array [ +guinea-pig-implementation+ get 20 IUnrelated::xPlus ] unit-test + 420 1array [ + +guinea-pig-implementation+ get + IUnrelated-iid com-query-interface + [ 20 20 IUnrelated::xMulAdd ] with-com-interface + ] unit-test + 40 1array [ + +guinea-pig-implementation+ get + IUnrelated-iid com-query-interface + [ 20 IUnrelated::xPlus ] with-com-interface + ] unit-test +guinea-pig-implementation+ get 1array [ +guinea-pig-implementation+ get com-add-ref @@ -56,14 +69,23 @@ dup +test-vtbl+ set [ +guinea-pig-implementation+ get 1array [ +guinea-pig-implementation+ get IUnknown-iid com-query-interface + dup com-release ] unit-test +guinea-pig-implementation+ get 1array [ +guinea-pig-implementation+ get ISimple-iid com-query-interface + dup com-release ] unit-test - "void*" heap-size +guinea-pig-implementation+ get 1array [ + "void*" heap-size +guinea-pig-implementation+ get + +guinea-pig-implementation+ get + 2array [ +guinea-pig-implementation+ get IUnrelated-iid com-query-interface + dup ISimple-iid com-query-interface + over com-release dup com-release ] unit-test ] with-com-interface -] [ free-com-vtbl ] [ ] cleanup +] with-disposal + +! Ensure that we freed +guinea-pig-implementation ++orig-wrapped-objects+ get-global 1array [ +wrapped-objects+ get-global ] unit-test diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor index b78d9b5b91..4833a7412a 100644 --- a/extra/windows/com/com.factor +++ b/extra/windows/com/com.factor @@ -1,12 +1,31 @@ USING: alien alien.c-types windows.com.syntax windows.ole32 -windows.types continuations kernel ; +windows.types continuations kernel alien.syntax ; IN: windows.com +LIBRARY: ole32 + COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} HRESULT QueryInterface ( REFGUID iid, void** ppvObject ) ULONG AddRef ( ) ULONG Release ( ) ; +COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046} + HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) + HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) + HRESULT QueryGetData ( FORMATETC* pFormatetc ) + HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut ) + HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease ) + HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc ) + HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection ) + HRESULT DUnadvise ( DWORD pdwConnection ) + HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ; + +COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} + HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) + HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) + HRESULT DragLeave ( ) + HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; + : com-query-interface ( interface iid -- interface' ) f [ IUnknown::QueryInterface ole32-error ] keep @@ -19,4 +38,4 @@ COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} IUnknown::Release drop ; inline : with-com-interface ( interface quot -- ) - [ keep ] [ com-release ] [ ] cleanup ; inline + over [ slip ] [ com-release ] [ ] cleanup ; inline diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index 5884c18aee..216ca8707d 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -57,8 +57,12 @@ unless : (function-word) ( function interface -- word ) name>> "::" rot name>> 3append create-in ; -: all-functions ( definition -- functions ) - dup parent>> [ all-functions ] [ { } ] if* +: family-tree ( definition -- definitions ) + dup parent>> [ family-tree ] [ { } ] if* + swap add ; + +: family-tree-functions ( definition -- functions ) + dup parent>> [ family-tree-functions ] [ { } ] if* swap functions>> append ; : (define-word-for-function) ( function interface n -- ) @@ -71,7 +75,7 @@ unless [ [ (iid-word) ] [ iid>> 1quotation ] bi define ] [ name>> "com-interface" swap typedef ] [ - dup all-functions + dup family-tree-functions [ (define-word-for-function) ] with each-index ] tri ; diff --git a/extra/windows/com/wrapper/wrapper-docs.factor b/extra/windows/com/wrapper/wrapper-docs.factor new file mode 100755 index 0000000000..51a3549047 --- /dev/null +++ b/extra/windows/com/wrapper/wrapper-docs.factor @@ -0,0 +1,40 @@ +USING: help.markup help.syntax io kernel math quotations +multiline alien windows.com windows.com.syntax continuations ; +IN: windows.com.wrapper + +HELP: +{ $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } } +{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper objects and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" } +{ $code <" +COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} + HRESULT returnOK ( ) + HRESULT returnError ( ) ; + +COM-INTERFACE: IInherited ISimple {9620ecec-8438-423b-bb14-86f835aa40dd} + int getX ( ) + void setX ( int newX ) ; + +COM-INTERFACE: IUnrelated IUnknown {b06ac3f4-30e4-406b-a7cd-c29cead4552c} + int xPlus ( int y ) + int xMulAdd ( int mul, int add ) ; + +{ + { "IInherited" { + [ drop S_OK ] ! ISimple::returnOK + [ drop E_FAIL ] ! ISimple::returnError + [ x>> ] ! IInherited::getX + [ >>x drop ] ! IInherited::setX + } } + { "IUnrelated" { + [ swap x>> + ] ! IUnrelated::xPlus + [ spin x>> * + ] ! IUnrealted::xMulAdd + } } +} +"> } ; + +HELP: com-wrap +{ $values { "object" "The factor object to wrap" } { "wrapper" "A " { $link com-wrapper } " object" } { "wrapped-object" "A COM object referencing " { $snippet "object" } } } +{ $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ; + +HELP: com-wrapper +{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link } " constructor and applied to a Factor object using " { $link com-wrap } "." } ; diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor new file mode 100755 index 0000000000..890674ed6d --- /dev/null +++ b/extra/windows/com/wrapper/wrapper.factor @@ -0,0 +1,111 @@ +USING: alien alien.c-types windows.com.syntax +windows.com.syntax.private windows.com continuations kernel +sequences.lib namespaces windows.ole32 libc +assocs accessors arrays sequences quotations combinators +math combinators.cleave combinators.lib words compiler.units ; +IN: windows.com.wrapper + +TUPLE: com-wrapper vtbls freed? ; + +byte-array ] % + [ + >r find-com-interface-definition family-tree + r> 1quotation [ >r iid>> r> 2array ] curry map + ] map-index concat + [ f ] add , + \ case , + "void*" heap-size + [ * rot com-add-ref 0 rot set-void*-nth S_OK ] + curry , + [ nip f 0 rot set-void*-nth E_NOINTERFACE ] , + \ if* , + ] [ ] make ; + +: (make-add-ref) ( interfaces -- quot ) + length "void*" heap-size * [ swap + 0 over ulong-nth + 1+ [ 0 rot set-ulong-nth ] keep + ] curry ; + +: (make-release) ( interfaces -- quot ) + length "void*" heap-size * [ over + 0 over ulong-nth + 1- [ 0 rot set-ulong-nth ] keep + dup zero? [ swap (free-wrapped-object) ] [ nip ] if + ] curry ; + +: (make-iunknown-methods) ( interfaces -- quots ) + [ (make-query-interface) ] + [ (make-add-ref) ] + [ (make-release) ] tri + 3array ; + +: (thunk) ( n -- quot ) + dup 0 = + [ drop [ ] ] + [ "void*" heap-size neg * [ swap ] curry ] + if ; + +: (thunked-quots) ( quots iunknown-methods thunk -- quots' ) + [ [ swap 2array ] curry map swap ] keep + [ com-unwrap ] compose [ swap 2array ] curry map append ; + +: compile-alien-callback ( return parameters abi quot -- alien ) + [ alien-callback ] 4 ncurry + [ gensym [ swap define ] keep ] with-compilation-unit + execute ; + +: (make-vtbl) ( interface-name quots iunknown-methods n -- ) + (thunk) (thunked-quots) + swap find-com-interface-definition family-tree-functions [ + { return>> parameters>> } get-slots + dup length 1- roll [ + first dup empty? + [ 2drop [ ] ] + [ swap [ ndip ] 2curry ] + if + ] [ second ] bi compose + "stdcall" swap compile-alien-callback + ] 2map >c-void*-array [ byte-length malloc ] keep + over byte-array>memory ; + +: (make-vtbls) ( implementations -- vtbls ) + dup [ first ] map (make-iunknown-methods) + [ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ; + +: (malloc-wrapped-object) ( wrapper -- wrapped-object ) + vtbls>> length "void*" heap-size * + [ "ulong" heap-size + malloc ] keep + over + 1 0 rot set-ulong-nth ; + +PRIVATE> + +: ( implementations -- wrapper ) + (make-vtbls) f com-wrapper construct-boa ; + +M: com-wrapper dispose + t >>freed? + vtbls>> [ free ] each ; + +: com-wrap ( object wrapper -- wrapped-object ) + dup (malloc-wrapped-object) >r vtbls>> r> + [ [ set-void*-nth ] curry each-index ] keep + [ +wrapped-objects+ get-global set-at ] keep ; diff --git a/extra/windows/dragdrop-listener/dragdrop-listener.factor b/extra/windows/dragdrop-listener/dragdrop-listener.factor new file mode 100644 index 0000000000..a7851621ff --- /dev/null +++ b/extra/windows/dragdrop-listener/dragdrop-listener.factor @@ -0,0 +1,70 @@ +USING: windows.com windows.com.wrapper combinators.cleave +windows.kernel32 windows.ole32 windows.shell32 kernel accessors +prettyprint namespaces ui.tools.listener ui.tools.workspace +alien.c-types alien sequences math ; +IN: windows.dragdrop + +: filenames-from-hdrop ( hdrop -- filenames ) + dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files + [ + 2dup f 0 DragQueryFile 1+ ! get size of filename buffer + dup "WCHAR" + [ swap DragQueryFile drop ] keep + alien>u16-string + ] with map ; + +: filenames-from-data-object ( data-object -- filenames ) + "FORMATETC" + CF_HDROP over set-FORMATETC-cfFormat + f over set-FORMATETC-ptd + DVASPECT_CONTENT over set-FORMATETC-dwAspect + -1 over set-FORMATETC-lindex + TYMED_HGLOBAL over set-FORMATETC-tymed + "STGMEDIUM" + [ IDataObject::GetData ] keep swap succeeded? [ + dup STGMEDIUM-data + [ filenames-from-hdrop ] with-global-lock + swap ReleaseStgMedium + ] [ drop f ] if ; + +TUPLE: listener-dragdrop hWnd last-drop-effect ; + +: ( hWnd -- object ) + DROPEFFECT_NONE listener-dragdrop construct-boa ; + +SYMBOL: +listener-dragdrop-wrapper+ +{ + { "IDropTarget" { + [ ! DragEnter + >r 2drop + filenames-from-data-object + length 1 = [ DROPEFFECT_COPY ] [ DROPEFFECT_NONE ] if + dup 0 r> set-ulong-nth + >>last-drop-effect drop + S_OK + ] [ ! DragOver + >r 2drop last-drop-effect>> 0 r> set-ulong-nth + S_OK + ] [ ! DragLeave + drop S_OK + ] [ ! Drop + >r 2drop nip + filenames-from-data-object + dup length 1 = [ + first unparse [ "USE: parser " % % " run-file" % ] "" make + eval-listener + DROPEFFECT_COPY + ] [ + 2drop DROPEFFECT_NONE + ] if + 0 r> set-ulong-nth + S_OK + ] + } } +} +listener-dragdrop-wrapper+ set-global + +: dragdrop-listener-window ( -- ) + get-workspace parent>> handle>> hWnd>> + dup + +listener-dragdrop-wrapper+ get-global com-wrap + [ RegisterDragDrop ole32-error ] with-com-interface ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 37b833cae1..5530c0871f 100644 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax windows.types ; +USING: alien alien.syntax kernel windows.types ; IN: windows.kernel32 : MAX_PATH 260 ; inline @@ -1564,3 +1564,6 @@ FUNCTION: BOOL WriteProcessMemory ( HANDLE hProcess, void* lpBaseAddress, void* ! FUNCTION: WriteTapemark ! FUNCTION: WTSGetActiveConsoleSessionId ! FUNCTION: ZombifyActCtx + +: with-global-lock ( HGLOBAL quot -- ) + swap [ GlobalLock swap call ] keep GlobalUnlock drop ; inline diff --git a/extra/windows/ole32/ole32.factor b/extra/windows/ole32/ole32.factor index 44ea853af0..3be442514c 100644 --- a/extra/windows/ole32/ole32.factor +++ b/extra/windows/ole32/ole32.factor @@ -1,16 +1,10 @@ USING: alien alien.syntax alien.c-types math kernel sequences -windows windows.types combinators.lib ; +windows windows.kernel32 windows.types combinators.lib ; IN: windows.ole32 LIBRARY: ole32 -C-STRUCT: GUID - { "DWORD" "part1" } - { "DWORD" "part2" } - { "DWORD" "part3" } - { "DWORD" "part4" } ; - -TYPEDEF: void* REFGUID +TYPEDEF: GUID* REFGUID TYPEDEF: void* LPUNKNOWN TYPEDEF: ushort* LPOLESTR TYPEDEF: ushort* LPCOLESTR @@ -25,6 +19,7 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ; : S_OK 0 ; inline : S_FALSE 1 ; inline +: E_NOINTERFACE HEX: 80004002 ; inline : E_FAIL HEX: 80004005 ; inline : E_INVALIDARG HEX: 80070057 ; inline @@ -40,11 +35,92 @@ FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ; : DD_DEFDRAGDELAY 200 ; inline : DD_DEFDRAGMINDIST 2 ; inline -: ole32-error ( n -- ) - dup S_OK = [ +: CF_TEXT 1 ; inline +: CF_BITMAP 2 ; inline +: CF_METAFILEPICT 3 ; inline +: CF_SYLK 4 ; inline +: CF_DIF 5 ; inline +: CF_TIFF 6 ; inline +: CF_OEMTEXT 7 ; inline +: CF_DIB 8 ; inline +: CF_PALETTE 9 ; inline +: CF_PENDATA 10 ; inline +: CF_RIFF 11 ; inline +: CF_WAVE 12 ; inline +: CF_UNICODETEXT 13 ; inline +: CF_ENHMETAFILE 14 ; inline +: CF_HDROP 15 ; inline +: CF_LOCALE 16 ; inline +: CF_MAX 17 ; inline + +: CF_OWNERDISPLAY HEX: 0080 ; inline +: CF_DSPTEXT HEX: 0081 ; inline +: CF_DSPBITMAP HEX: 0082 ; inline +: CF_DSPMETAFILEPICT HEX: 0083 ; inline +: CF_DSPENHMETAFILE HEX: 008E ; inline + +: DVASPECT_CONTENT 1 ; inline +: DVASPECT_THUMBNAIL 2 ; inline +: DVASPECT_ICON 4 ; inline +: DVASPECT_DOCPRINT 8 ; inline + +: TYMED_HGLOBAL 1 ; inline +: TYMED_FILE 2 ; inline +: TYMED_ISTREAM 4 ; inline +: TYMED_ISTORAGE 8 ; inline +: TYMED_GDI 16 ; inline +: TYMED_MFPICT 32 ; inline +: TYMED_ENHMF 64 ; inline +: TYMED_NULL 0 ; inline + +C-STRUCT: DVTARGETDEVICE + { "DWORD" "tdSize" } + { "WORD" "tdDriverNameOffset" } + { "WORD" "tdDeviceNameOffset" } + { "WORD" "tdPortNameOffset" } + { "WORD" "tdExtDevmodeOffset" } + { "BYTE[1]" "tdData" } ; + +TYPEDEF: WORD CLIPFORMAT +TYPEDEF: POINT POINTL + +C-STRUCT: FORMATETC + { "CLIPFORMAT" "cfFormat" } + { "DVTARGETDEVICE*" "ptd" } + { "DWORD" "dwAspect" } + { "LONG" "lindex" } + { "DWORD" "tymed" } ; +TYPEDEF: FORMATETC* LPFORMATETC + +C-STRUCT: STGMEDIUM + { "DWORD" "tymed" } + { "void*" "data" } + { "LPUNKNOWN" "punkForRelease" } ; +TYPEDEF: STGMEDIUM* LPSTGMEDIUM + +: COINIT_MULTITHREADED 0 ; inline +: COINIT_APARTMENTTHREADED 2 ; inline +: COINIT_DISABLE_OLE1DDE 4 ; inline +: COINIT_SPEED_OVER_MEMORY 8 ; inline + +FUNCTION: HRESULT OleInitialize ( void* reserved ) ; +FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ; + +FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ; +FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ; +FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; + +: succeeded? ( hresult -- ? ) + 0 HEX: 7FFFFFFF between? ; + +: ole32-error ( hresult -- ) + dup succeeded? [ drop ] [ (win32-error-string) throw ] if ; +: ole-initialize ( -- ) + f OleInitialize ole32-error ; + : guid= ( a b -- ? ) IsEqualGUID c-bool> ; diff --git a/extra/windows/shell32/shell32.factor b/extra/windows/shell32/shell32.factor index d64fb68cb3..a5bed9daed 100644 --- a/extra/windows/shell32/shell32.factor +++ b/extra/windows/shell32/shell32.factor @@ -167,6 +167,15 @@ TYPEDEF: DWORD SHGDNF TYPEDEF: ULONG SFGAOF +C-STRUCT: DROPFILES + { "DWORD" "pFiles" } + { "POINT" "pt" } + { "BOOL" "fNC" } + { "BOOL" "fWide" } ; +TYPEDEF: DROPFILES* LPDROPFILES +TYPEDEF: DROPFILES* LPCDROPFILES +TYPEDEF: HANDLE HDROP + C-STRUCT: SHITEMID { "USHORT" "cb" } { "BYTE[1]" "abID" } ; @@ -210,5 +219,6 @@ COM-INTERFACE: IShellFolder IUnknown {000214E6-0000-0000-C000-000000000046} FUNCTION: HRESULT SHGetDesktopFolder ( IShellFolder** ppshf ) ; -FUNCTION: HRESULT StrRetToBufW ( STRRET *pstr, PCUITEMID_CHILD pidl, LPWSTR pszBuf, UINT cchBuf ) ; -: StrRetToBuf StrRetToBufW ; inline +FUNCTION: UINT DragQueryFileW ( HDROP hDrop, UINT iFile, LPWSTR lpszFile, UINT cch ) ; +: DragQueryFile DragQueryFileW ; inline + diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor old mode 100755 new mode 100644 From 1c58671b9ed691dcd2545d5b692dd5979b4023da Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 31 Mar 2008 12:34:58 -0700 Subject: [PATCH 03/14] Metadata files for windows.com.wrapper vocab --- extra/windows/com/wrapper/authors.txt | 1 + extra/windows/com/wrapper/summary.txt | 1 + extra/windows/com/wrapper/tags.txt | 3 +++ extra/windows/com/wrapper/wrapper-docs.factor | 0 extra/windows/com/wrapper/wrapper.factor | 0 5 files changed, 5 insertions(+) create mode 100644 extra/windows/com/wrapper/authors.txt create mode 100644 extra/windows/com/wrapper/summary.txt create mode 100644 extra/windows/com/wrapper/tags.txt mode change 100755 => 100644 extra/windows/com/wrapper/wrapper-docs.factor mode change 100755 => 100644 extra/windows/com/wrapper/wrapper.factor diff --git a/extra/windows/com/wrapper/authors.txt b/extra/windows/com/wrapper/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/windows/com/wrapper/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/windows/com/wrapper/summary.txt b/extra/windows/com/wrapper/summary.txt new file mode 100644 index 0000000000..c43941984e --- /dev/null +++ b/extra/windows/com/wrapper/summary.txt @@ -0,0 +1 @@ +Wrap Factor objects with implementations of COM interfaces diff --git a/extra/windows/com/wrapper/tags.txt b/extra/windows/com/wrapper/tags.txt new file mode 100644 index 0000000000..ffb665dc8f --- /dev/null +++ b/extra/windows/com/wrapper/tags.txt @@ -0,0 +1,3 @@ +windows +com +bindings diff --git a/extra/windows/com/wrapper/wrapper-docs.factor b/extra/windows/com/wrapper/wrapper-docs.factor old mode 100755 new mode 100644 diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor old mode 100755 new mode 100644 From b5be6236c5c122b796c5b2451edfd785d959febd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 31 Mar 2008 12:56:23 -0700 Subject: [PATCH 04/14] Remove combinators.cleave references from windows.com.wrapper and dragdrop-listener --- extra/windows/com/wrapper/wrapper.factor | 2 +- extra/windows/dragdrop-listener/dragdrop-listener.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 890674ed6d..7f63f529a6 100644 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types windows.com.syntax windows.com.syntax.private windows.com continuations kernel sequences.lib namespaces windows.ole32 libc assocs accessors arrays sequences quotations combinators -math combinators.cleave combinators.lib words compiler.units ; +math combinators.lib words compiler.units ; IN: windows.com.wrapper TUPLE: com-wrapper vtbls freed? ; diff --git a/extra/windows/dragdrop-listener/dragdrop-listener.factor b/extra/windows/dragdrop-listener/dragdrop-listener.factor index a7851621ff..0776d37625 100644 --- a/extra/windows/dragdrop-listener/dragdrop-listener.factor +++ b/extra/windows/dragdrop-listener/dragdrop-listener.factor @@ -1,4 +1,4 @@ -USING: windows.com windows.com.wrapper combinators.cleave +USING: windows.com windows.com.wrapper combinators windows.kernel32 windows.ole32 windows.shell32 kernel accessors prettyprint namespaces ui.tools.listener ui.tools.workspace alien.c-types alien sequences math ; From 71b58d1a2a4813f101c9977ca8621f3308223ea5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 31 Mar 2008 13:13:16 -0700 Subject: [PATCH 05/14] Fix name of windows.dragdrop-listener vocab --- extra/windows/dragdrop-listener/dragdrop-listener.factor | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/extra/windows/dragdrop-listener/dragdrop-listener.factor b/extra/windows/dragdrop-listener/dragdrop-listener.factor index 0776d37625..8384bb1acc 100644 --- a/extra/windows/dragdrop-listener/dragdrop-listener.factor +++ b/extra/windows/dragdrop-listener/dragdrop-listener.factor @@ -2,7 +2,7 @@ USING: windows.com windows.com.wrapper combinators windows.kernel32 windows.ole32 windows.shell32 kernel accessors prettyprint namespaces ui.tools.listener ui.tools.workspace alien.c-types alien sequences math ; -IN: windows.dragdrop +IN: windows.dragdrop-listener : filenames-from-hdrop ( hdrop -- filenames ) dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files @@ -54,9 +54,7 @@ SYMBOL: +listener-dragdrop-wrapper+ first unparse [ "USE: parser " % % " run-file" % ] "" make eval-listener DROPEFFECT_COPY - ] [ - 2drop DROPEFFECT_NONE - ] if + ] [ 2drop DROPEFFECT_NONE ] if 0 r> set-ulong-nth S_OK ] From b2e90f62c0c88ca915848463d86165dc4f26e8ed Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Apr 2008 20:36:58 -0700 Subject: [PATCH 06/14] Modernize some code in the bunny demo --- extra/bunny/bunny.factor | 35 ++++++------- extra/bunny/outlined/outlined.factor | 16 +++--- extra/opengl/demo-support/demo-support.factor | 50 ++++++++++++------- 3 files changed, 53 insertions(+), 48 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 43b9edcd00..6efa739677 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -4,7 +4,7 @@ opengl.glu shuffle http.client vectors namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting combinators tools.time system combinators.lib float-arrays continuations opengl.demo-support multiline ui.gestures bunny.fixed-pipeline -bunny.cel-shaded bunny.outlined bunny.model ; +bunny.cel-shaded bunny.outlined bunny.model accessors ; IN: bunny TUPLE: bunny-gadget model geom draw-seq draw-n ; @@ -17,34 +17,29 @@ TUPLE: bunny-gadget model geom draw-seq draw-n ; } bunny-gadget construct ; : bunny-gadget-draw ( gadget -- draw ) - { bunny-gadget-draw-n bunny-gadget-draw-seq } + { draw-n>> draw-seq>> } get-slots nth ; : bunny-gadget-next-draw ( gadget -- ) - dup { bunny-gadget-draw-seq bunny-gadget-draw-n } + dup { draw-seq>> draw-n>> } get-slots 1+ swap length mod - swap [ set-bunny-gadget-draw-n ] keep relayout-1 ; + >>draw-n relayout-1 ; M: bunny-gadget graft* ( gadget -- ) GL_DEPTH_TEST glEnable - dup bunny-gadget-model - over { - [ ] - [ ] - [ ] - } map-call-with [ ] subset - 0 - roll { - set-bunny-gadget-geom - set-bunny-gadget-draw-seq - set-bunny-gadget-draw-n - } set-slots ; + dup model>> >>geom + dup + [ ] + [ ] + [ ] tri 3array + [ ] subset >>draw-seq + 0 >>draw-n + drop ; M: bunny-gadget ungraft* ( gadget -- ) - { bunny-gadget-geom bunny-gadget-draw-seq } get-slots - [ [ dispose ] when* ] each - [ dispose ] when* ; + [ geom>> [ dispose ] when* ] + [ draw-seq>> [ [ dispose ] when* ] each ] bi ; M: bunny-gadget draw-gadget* ( gadget -- ) 0.15 0.15 0.15 1.0 glClearColor @@ -52,7 +47,7 @@ M: bunny-gadget draw-gadget* ( gadget -- ) dup demo-gadget-set-matrices GL_MODELVIEW glMatrixMode 0.02 -0.105 0.0 glTranslatef - { bunny-gadget-geom bunny-gadget-draw } get-slots + { geom>> bunny-gadget-draw } get-slots draw-bunny ; M: bunny-gadget pref-dim* ( gadget -- dim ) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 6a2f54cceb..85202e4185 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -183,8 +183,7 @@ TUPLE: bunny-outlined dup bunny-outlined-gadget rect-dim over bunny-outlined-framebuffer-dim over = - [ 2drop ] - [ + [ 2drop ] [ swap dup dispose-framebuffer >r dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) @@ -228,12 +227,11 @@ TUPLE: bunny-outlined } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ; M: bunny-outlined draw-bunny - dup remake-framebuffer-if-needed - [ (pass1) ] keep (pass2) ; + [ remake-framebuffer-if-needed ] + [ (pass1) ] + [ (pass2) ] tri ; M: bunny-outlined dispose - { - [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] - [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] - [ dispose-framebuffer ] - } cleave ; + [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] + [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] + [ dispose-framebuffer ] tri diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 84515305c8..524567b5bd 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -2,13 +2,9 @@ USING: arrays combinators.lib kernel math math.functions math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; IN: opengl.demo-support -: NEAR-PLANE 1.0 64.0 / ; inline -: FAR-PLANE 4.0 ; inline : FOV 2.0 sqrt 1+ ; inline : MOUSE-MOTION-SCALE 0.5 ; inline -: MOUSE-DISTANCE-SCALE 1.0 64.0 / ; inline : KEY-ROTATE-STEP 1.0 ; inline -: KEY-DISTANCE-STEP 1.0 64.0 / ; inline : DIMS { 640 480 } ; inline : FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ; @@ -21,6 +17,17 @@ TUPLE: demo-gadget yaw pitch distance ; demo-gadget construct-gadget [ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ; +GENERIC: far-plane ( gadget -- z ) +GENERIC: near-plane ( gadget -- z ) +GENERIC: distance-step ( gadget -- dz ) + +M: demo-gadget far-plane ( gadget -- z ) + drop 4.0 ; +M: demo-gadget near-plane ( gadget -- z ) + drop 1.0 64.0 / ; +M: demo-gadget distance-step ( gadget -- dz ) + drop 1.0 64.0 / ; + : yaw-demo-gadget ( yaw gadget -- ) [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ; @@ -36,21 +43,26 @@ M: demo-gadget pref-dim* ( gadget -- dim ) : -+ ( x -- -x x ) dup neg swap ; -: demo-gadget-frustum ( -- -x x -y y near far ) - FOV-RATIO NEAR-PLANE FOV / v*n - first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ; +: demo-gadget-frustum ( gadget -- -x x -y y near far ) + [ near-plane ] [ far-plane ] bi [ + drop FOV-RATIO swap FOV / v*n + first2 [ -+ ] bi@ + ] 2keep ; : demo-gadget-set-matrices ( gadget -- ) - GL_PROJECTION glMatrixMode - glLoadIdentity - demo-gadget-frustum glFrustum GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - GL_MODELVIEW glMatrixMode - glLoadIdentity - [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] - [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] - [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] - tri ; + [ + GL_PROJECTION glMatrixMode + glLoadIdentity + demo-gadget-frustum glFrustum + ] [ + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] + [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] + [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] + tri + ] bi ; : reset-last-drag-rel ( -- ) { 0 0 } last-drag-loc set-global ; @@ -65,11 +77,11 @@ demo-gadget H{ { 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 "=" } [ KEY-DISTANCE-STEP neg swap zoom-demo-gadget ] } - { T{ key-down f f "-" } [ KEY-DISTANCE-STEP swap zoom-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 ] } { 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 ] } - { T{ mouse-scroll } [ scroll-direction get second MOUSE-DISTANCE-SCALE * swap zoom-demo-gadget ] } + { T{ mouse-scroll } [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] } } set-gestures From 7a9f379944698ac8a67658b03f8cd907df84bbf2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Apr 2008 20:37:34 -0700 Subject: [PATCH 07/14] Add spheres demo --- extra/spheres/spheres.factor | 233 +++++++++++++++++++++++++++++++++++ 1 file changed, 233 insertions(+) create mode 100644 extra/spheres/spheres.factor diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor new file mode 100644 index 0000000000..d8ecb2da98 --- /dev/null +++ b/extra/spheres/spheres.factor @@ -0,0 +1,233 @@ +USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers +opengl multiline ui.gadgets accessors sequences ui.render ui math +arrays.lib combinators ; +IN: spheres + +STRING: plane-vertex-shader +varying vec3 object_position; +void +main() +{ + object_position = gl_Vertex.xyz; + gl_Position = ftransform(); +} +; + +STRING: plane-fragment-shader +varying vec3 object_position; +void +main() +{ + float distance_factor = (gl_FragCoord.z * 0.5 + 0.5); + distance_factor = pow(distance_factor, 500.0)*0.5; + + gl_FragColor = fract((floor(0.125*object_position.x)+floor(0.125*object_position.z)) * 0.5) == 0.0 + ? vec4(1.0, 1.0 - distance_factor, 1.0 - distance_factor, 1.0) + : vec4(1.0, distance_factor, distance_factor, 1.0); +} +; + +STRING: sphere-vertex-shader +attribute vec3 center; +attribute float radius; +attribute vec4 surface_color; +varying float vradius; +varying vec3 sphere_position; +varying vec4 world_position, vcolor; + +void +main() +{ + world_position = gl_ModelViewMatrix * vec4(center, 1); + sphere_position = gl_Vertex.xyz; + + gl_Position = gl_ProjectionMatrix * (world_position + vec4(sphere_position * radius, 0)); + + vcolor = surface_color; + vradius = radius; +} +; + +STRING: sphere-fragment-shader +uniform vec3 light_position; +varying float vradius; +varying vec3 sphere_position; +varying vec4 world_position, vcolor; + +vec4 ambient = vec4(0.3, 0.2, 0.2, 1.0); +vec4 diffuse = vec4(0.7, 0.8, 0.8, 1.0); + +vec4 +light(vec3 point, vec3 normal) +{ + vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz; + vec3 direction = normalize(transformed_light_position - point); + float d = max(0.0, dot(normal, direction)); + + return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a); +} + +void +main() +{ + float radius = length(sphere_position); + if(radius > 1.0) discard; + + vec3 surface = sphere_position + vec3(0.0, 0.0, sqrt(1.0 - radius*radius)); + vec4 world_surface = world_position + vec4(surface * vradius, 0); + vec4 transformed_surface = gl_ProjectionMatrix * world_surface; + + gl_FragDepth = (transformed_surface.z/transformed_surface.w + 1.0) * 0.5; + gl_FragColor = light(world_surface.xyz, surface); +} +; + +TUPLE: spheres-gadget + plane-program sphere-program + reflection-framebuffer reflection-depthbuffer + reflection-texture ; + +: ( -- gadget ) + 0.0 0.0 20.0 + { set-delegate } spheres-gadget construct ; + +M: spheres-gadget near-plane ( gadget -- z ) + drop 1.0 ; +M: spheres-gadget far-plane ( gadget -- z ) + drop 512.0 ; +M: spheres-gadget distance-step ( gadget -- dz ) + drop 0.5 ; + +: (make-reflection-texture) ( -- texture ) + gen-texture [ + GL_TEXTURE_CUBE_MAP swap glBindTexture + GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER GL_LINEAR 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 + [ 0 GL_RGBA8 1024 1024 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] + each + ] keep ; + +: (make-reflection-depthbuffer) ( -- depthbuffer ) + gen-renderbuffer [ + GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT + GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 1024 1024 glRenderbufferStorageEXT + ] keep ; + +: (make-reflection-framebuffer) ( depthbuffer -- framebuffer ) + gen-framebuffer dup [ + swap >r + GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT r> + glFramebufferRenderbufferEXT + ] with-framebuffer ; + +M: spheres-gadget graft* ( gadget -- ) + plane-vertex-shader plane-fragment-shader + >>plane-program + sphere-vertex-shader sphere-fragment-shader + >>sphere-program + (make-reflection-texture) >>reflection-texture + (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep + (make-reflection-framebuffer) >>reflection-framebuffer + drop ; + +M: spheres-gadget ungraft* ( gadget -- ) + { + [ reflection-framebuffer>> [ delete-framebuffer ] when* ] + [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] + [ reflection-texture>> [ delete-texture ] when* ] + [ sphere-program>> [ delete-gl-program ] when* ] + [ plane-program>> [ delete-gl-program ] when* ] + } cleave ; + +M: spheres-gadget pref-dim* ( gadget -- dim ) + drop { 640 480 } ; + +: (draw-sphere) ( program center radius surfacecolor -- ) + roll + [ [ "center" glGetAttribLocation swap first3 glVertexAttrib3f ] curry ] + [ [ "radius" glGetAttribLocation swap glVertexAttrib1f ] curry ] + [ [ "surface_color" glGetAttribLocation swap first4 glVertexAttrib4f ] curry ] + tri tri* + { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ; + +: sphere-scene ( gadget -- ) + GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor + glClear + [ + sphere-program>> dup { + { "light_position" [ 0.0 0.0 100.0 glUniform3f ] } + } [ + [ { 0.0 0.0 0.0 } 4.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ] + [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ] + [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ] tri + ] with-gl-program + ] [ + plane-program>> { } [ + GL_QUADS [ + -1000.0 -30.0 1000.0 glVertex3f + -1000.0 -30.0 -1000.0 glVertex3f + 1000.0 -30.0 -1000.0 glVertex3f + 1000.0 -30.0 1000.0 glVertex3f + ] do-state + ] with-gl-program + ] bi ; + +: reflection-frustum ( gadget -- -x x -y y near far ) + [ near-plane ] [ far-plane ] bi [ + drop dup [ -+ ] bi@ + ] 2keep ; + +: (reflection-face) ( gadget face -- ) + swap reflection-texture>> >r >r + GL_FRAMEBUFFER_EXT + GL_COLOR_ATTACHMENT0_EXT + r> r> 0 glFramebufferTexture2DEXT ; + +M: spheres-gadget draw-gadget* ( gadget -- ) + GL_DEPTH_TEST glEnable + 0.15 0.15 1.0 1.0 glClearColor { + [ + GL_PROJECTION glMatrixMode + glLoadIdentity + reflection-frustum glFrustum + GL_MODELVIEW glMatrixMode + glLoadIdentity + glPushMatrix + ] + [ + dup reflection-framebuffer>> [ { + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face) + glPopMatrix glPushMatrix + 90.0 1.0 0.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face) + glPopMatrix + -90.0 1.0 0.0 0.0 glRotatef ] + [ sphere-scene ] + } cleave ] with-framebuffer + ] + [ demo-gadget-set-matrices ] + [ sphere-scene ] + } cleave ; + +: spheres-window ( -- ) + [ "Spheres" open-window ] with-ui ; + +MAIN: spheres-window From b26eadc5ea12599ebe4ed3b2bb370ebe34b774dd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 15 Apr 2008 20:39:12 -0700 Subject: [PATCH 08/14] Metadata for spheres vocab --- extra/spheres/authors.txt | 1 + extra/spheres/summary.txt | 1 + extra/spheres/tags.txt | 2 ++ 3 files changed, 4 insertions(+) create mode 100644 extra/spheres/authors.txt create mode 100644 extra/spheres/summary.txt create mode 100644 extra/spheres/tags.txt diff --git a/extra/spheres/authors.txt b/extra/spheres/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/spheres/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/spheres/summary.txt b/extra/spheres/summary.txt new file mode 100644 index 0000000000..fd97091e33 --- /dev/null +++ b/extra/spheres/summary.txt @@ -0,0 +1 @@ +Draw pixel-perfect spheres using GLSL shaders \ No newline at end of file diff --git a/extra/spheres/tags.txt b/extra/spheres/tags.txt new file mode 100644 index 0000000000..2e6040bd16 --- /dev/null +++ b/extra/spheres/tags.txt @@ -0,0 +1,2 @@ +opengl +glsl From 60025d45c37e6b744852723b4cd5b0709defa394 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 16 Apr 2008 21:06:13 -0700 Subject: [PATCH 09/14] Add environment mapping to spheres demo. Modernize more code in bunny and demo-support --- extra/bunny/outlined/outlined.factor | 2 +- extra/opengl/demo-support/demo-support.factor | 23 ++- extra/spheres/spheres.factor | 151 ++++++++++++------ 3 files changed, 112 insertions(+), 64 deletions(-) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 85202e4185..9c4e8b22a2 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -234,4 +234,4 @@ M: bunny-outlined draw-bunny M: bunny-outlined dispose [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] - [ dispose-framebuffer ] tri + [ dispose-framebuffer ] tri ; diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 524567b5bd..adc30e6f0f 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,13 +1,10 @@ USING: arrays combinators.lib kernel math math.functions math.vectors namespaces - opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; + opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render accessors ; IN: opengl.demo-support : FOV 2.0 sqrt 1+ ; inline : MOUSE-MOTION-SCALE 0.5 ; inline : KEY-ROTATE-STEP 1.0 ; inline -: DIMS { 640 480 } ; inline - -: FOV-RATIO ( -- fov ) DIMS dup first2 min v/n ; SYMBOL: last-drag-loc @@ -15,7 +12,7 @@ TUPLE: demo-gadget yaw pitch distance ; : ( yaw pitch distance -- gadget ) demo-gadget construct-gadget - [ { set-demo-gadget-yaw set-demo-gadget-pitch set-demo-gadget-distance } set-slots ] keep ; + [ { (>>yaw) (>>pitch) (>>distance) } set-slots ] keep ; GENERIC: far-plane ( gadget -- z ) GENERIC: near-plane ( gadget -- z ) @@ -28,6 +25,8 @@ M: demo-gadget near-plane ( gadget -- z ) M: demo-gadget distance-step ( gadget -- dz ) drop 1.0 64.0 / ; +: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ; + : yaw-demo-gadget ( yaw gadget -- ) [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ; @@ -38,16 +37,16 @@ M: demo-gadget distance-step ( gadget -- dz ) [ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ; M: demo-gadget pref-dim* ( gadget -- dim ) - drop DIMS ; + drop { 640 480 } ; : -+ ( x -- -x x ) dup neg swap ; : demo-gadget-frustum ( gadget -- -x x -y y near far ) - [ near-plane ] [ far-plane ] bi [ - drop FOV-RATIO swap FOV / v*n + [ near-plane ] [ far-plane ] [ fov-ratio ] tri [ + nip swap FOV / v*n first2 [ -+ ] bi@ - ] 2keep ; + ] 3keep drop ; : demo-gadget-set-matrices ( gadget -- ) GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear @@ -58,9 +57,9 @@ M: demo-gadget pref-dim* ( gadget -- dim ) ] [ GL_MODELVIEW glMatrixMode glLoadIdentity - [ >r 0.0 0.0 r> demo-gadget-distance neg glTranslatef ] - [ demo-gadget-pitch 1.0 0.0 0.0 glRotatef ] - [ demo-gadget-yaw 0.0 1.0 0.0 glRotatef ] + [ >r 0.0 0.0 r> distance>> neg glTranslatef ] + [ pitch>> 1.0 0.0 0.0 glRotatef ] + [ yaw>> 0.0 1.0 0.0 glRotatef ] tri ] bi ; diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index d8ecb2da98..6f1a7c7508 100644 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,6 +1,6 @@ USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers opengl multiline ui.gadgets accessors sequences ui.render ui math -arrays.lib combinators ; +arrays arrays.lib combinators ; IN: spheres STRING: plane-vertex-shader @@ -48,17 +48,15 @@ main() } ; -STRING: sphere-fragment-shader +STRING: sphere-solid-color-fragment-shader uniform vec3 light_position; -varying float vradius; -varying vec3 sphere_position; -varying vec4 world_position, vcolor; +varying vec4 vcolor; -vec4 ambient = vec4(0.3, 0.2, 0.2, 1.0); -vec4 diffuse = vec4(0.7, 0.8, 0.8, 1.0); +const vec4 ambient = vec4(0.25, 0.2, 0.25, 1.0); +const vec4 diffuse = vec4(0.75, 0.8, 0.75, 1.0); vec4 -light(vec3 point, vec3 normal) +sphere_color(vec3 point, vec3 normal) { vec3 transformed_light_position = (gl_ModelViewMatrix * vec4(light_position, 1)).xyz; vec3 direction = normalize(transformed_light_position - point); @@ -66,6 +64,25 @@ light(vec3 point, vec3 normal) return ambient * vcolor + diffuse * vec4(d * vcolor.rgb, vcolor.a); } +; + +STRING: sphere-texture-fragment-shader +uniform samplerCube surface_texture; + +vec4 +sphere_color(vec3 point, vec3 normal) +{ + vec3 reflect = reflect(normalize(point), normal); + return textureCube(surface_texture, reflect * gl_NormalMatrix); +} +; + +STRING: sphere-main-fragment-shader +varying float vradius; +varying vec3 sphere_position; +varying vec4 world_position; + +vec4 sphere_color(vec3 point, vec3 normal); void main() @@ -78,12 +95,12 @@ main() vec4 transformed_surface = gl_ProjectionMatrix * world_surface; gl_FragDepth = (transformed_surface.z/transformed_surface.w + 1.0) * 0.5; - gl_FragColor = light(world_surface.xyz, surface); + gl_FragColor = sphere_color(world_surface.xyz, surface); } ; TUPLE: spheres-gadget - plane-program sphere-program + plane-program solid-sphere-program texture-sphere-program reflection-framebuffer reflection-depthbuffer reflection-texture ; @@ -98,6 +115,9 @@ M: spheres-gadget far-plane ( gadget -- z ) M: spheres-gadget distance-step ( gadget -- dz ) drop 0.5 ; +: (reflection-dim) ( -- w h ) + 1024 1024 ; + : (make-reflection-texture) ( -- texture ) gen-texture [ GL_TEXTURE_CUBE_MAP swap glBindTexture @@ -109,14 +129,14 @@ M: spheres-gadget distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP_NEGATIVE_X GL_TEXTURE_CUBE_MAP_NEGATIVE_Y GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray - [ 0 GL_RGBA8 1024 1024 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] + [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ] each ] keep ; : (make-reflection-depthbuffer) ( -- depthbuffer ) gen-renderbuffer [ GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT - GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 1024 1024 glRenderbufferStorageEXT + GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorageEXT ] keep ; : (make-reflection-framebuffer) ( depthbuffer -- framebuffer ) @@ -126,11 +146,23 @@ M: spheres-gadget distance-step ( gadget -- dz ) glFramebufferRenderbufferEXT ] with-framebuffer ; +: (plane-program) ( -- program ) + plane-vertex-shader plane-fragment-shader ; +: (solid-sphere-program) ( -- program ) + sphere-vertex-shader check-gl-shader + sphere-solid-color-fragment-shader check-gl-shader + sphere-main-fragment-shader check-gl-shader + 3array check-gl-program ; +: (texture-sphere-program) ( -- program ) + sphere-vertex-shader check-gl-shader + sphere-texture-fragment-shader check-gl-shader + sphere-main-fragment-shader check-gl-shader + 3array check-gl-program ; + M: spheres-gadget graft* ( gadget -- ) - plane-vertex-shader plane-fragment-shader - >>plane-program - sphere-vertex-shader sphere-fragment-shader - >>sphere-program + (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 @@ -141,7 +173,8 @@ M: spheres-gadget ungraft* ( gadget -- ) [ reflection-framebuffer>> [ delete-framebuffer ] when* ] [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ] [ reflection-texture>> [ delete-texture ] when* ] - [ sphere-program>> [ delete-gl-program ] when* ] + [ solid-sphere-program>> [ delete-gl-program ] when* ] + [ texture-sphere-program>> [ delete-gl-program ] when* ] [ plane-program>> [ delete-gl-program ] when* ] } cleave ; @@ -157,15 +190,19 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ; : sphere-scene ( gadget -- ) - GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor - glClear + GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear [ - sphere-program>> dup { + solid-sphere-program>> dup { { "light_position" [ 0.0 0.0 100.0 glUniform3f ] } } [ - [ { 0.0 0.0 0.0 } 4.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ] - [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ] - [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ] tri + { + [ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ] + [ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ] + [ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ] + [ { 0.0 0.0 -7.0 } 1.0 { 1.0 1.0 0.0 1.0 } (draw-sphere) ] + [ { 0.0 7.0 0.0 } 1.0 { 1.0 0.0 1.0 1.0 } (draw-sphere) ] + [ { 0.0 -7.0 0.0 } 1.0 { 0.0 1.0 1.0 1.0 } (draw-sphere) ] + } cleave ] with-gl-program ] [ plane-program>> { } [ @@ -187,44 +224,56 @@ M: spheres-gadget pref-dim* ( gadget -- dim ) swap reflection-texture>> >r >r GL_FRAMEBUFFER_EXT GL_COLOR_ATTACHMENT0_EXT - r> r> 0 glFramebufferTexture2DEXT ; + r> r> 0 glFramebufferTexture2DEXT + check-framebuffer ; -M: spheres-gadget draw-gadget* ( gadget -- ) - GL_DEPTH_TEST glEnable - 0.15 0.15 1.0 1.0 glClearColor { +: (draw-reflection-texture) ( gadget -- ) + dup reflection-framebuffer>> [ { + [ drop 0 0 (reflection-dim) glViewport ] [ GL_PROJECTION glMatrixMode glLoadIdentity reflection-frustum glFrustum GL_MODELVIEW glMatrixMode glLoadIdentity - glPushMatrix - ] - [ - dup reflection-framebuffer>> [ { - [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face) - 90.0 0.0 1.0 0.0 glRotatef ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face) - 90.0 0.0 1.0 0.0 glRotatef ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face) - 90.0 0.0 1.0 0.0 glRotatef ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face) - glPopMatrix glPushMatrix - 90.0 1.0 0.0 0.0 glRotatef ] - [ sphere-scene ] - [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face) - glPopMatrix - -90.0 1.0 0.0 0.0 glRotatef ] - [ sphere-scene ] - } cleave ] with-framebuffer + 180.0 0.0 0.0 1.0 glRotatef ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z (reflection-face) ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_X (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef glPushMatrix ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X (reflection-face) + 90.0 0.0 1.0 0.0 glRotatef ] + [ sphere-scene ] + [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y (reflection-face) + glPopMatrix glPushMatrix -90.0 1.0 0.0 0.0 glRotatef ] + [ sphere-scene ] + [ 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 ] + } cleave ] with-framebuffer ; + +M: spheres-gadget draw-gadget* ( gadget -- ) + GL_DEPTH_TEST glEnable + GL_SCISSOR_TEST glDisable + 0.15 0.15 1.0 1.0 glClearColor { + [ (draw-reflection-texture) ] [ demo-gadget-set-matrices ] [ sphere-scene ] + [ + { texture-sphere-program>> reflection-texture>> } get-slots + GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit + dup { + { "surface_texture" [ 0 glUniform1i ] } + } [ + { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) + ] with-gl-program + ] } cleave ; : spheres-window ( -- ) From e68f0848c25b80344a0b2a2785953b461ca67a40 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 21 Apr 2008 20:18:39 -0700 Subject: [PATCH 10/14] Fix texture wrapping artifacts in sphere shader --- extra/spheres/spheres.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 6f1a7c7508..3975307280 100644 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -123,6 +123,9 @@ M: spheres-gadget distance-step ( gadget -- dz ) GL_TEXTURE_CUBE_MAP swap glBindTexture GL_TEXTURE_CUBE_MAP GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri GL_TEXTURE_CUBE_MAP GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri + 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 From 07b91613e466f7fcea594dc1d46e9679cb161db8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 21 Apr 2008 21:14:38 -0700 Subject: [PATCH 11/14] Modernize the bunny demo code --- extra/bunny/bunny.factor | 2 +- extra/bunny/cel-shaded/cel-shaded.factor | 9 +- .../fixed-pipeline/fixed-pipeline.factor | 2 +- extra/bunny/model/model.factor | 22 ++--- extra/bunny/outlined/outlined.factor | 82 ++++++++++--------- 5 files changed, 61 insertions(+), 56 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 6efa739677..5c2404ec84 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -13,7 +13,7 @@ TUPLE: bunny-gadget model geom draw-seq draw-n ; 0.0 0.0 0.375 maybe-download read-model { set-delegate - set-bunny-gadget-model + (>>model) } bunny-gadget construct ; : bunny-gadget-draw ( gadget -- draw ) diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor index d4f0b7612d..08bea0515b 100644 --- a/extra/bunny/cel-shaded/cel-shaded.factor +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -1,5 +1,5 @@ USING: arrays bunny.model continuations kernel multiline opengl opengl.shaders - opengl.capabilities opengl.gl sequences sequences.lib ; + opengl.capabilities opengl.gl sequences sequences.lib accessors ; IN: bunny.cel-shaded STRING: vertex-shader-source @@ -68,11 +68,12 @@ TUPLE: bunny-cel-shaded program ; : ( gadget -- draw ) drop cel-shading-supported? [ + bunny-cel-shaded new vertex-shader-source check-gl-shader cel-shaded-fragment-shader-lib-source check-gl-shader cel-shaded-fragment-shader-main-source check-gl-shader 3array check-gl-program - { set-bunny-cel-shaded-program } bunny-cel-shaded construct + >>program ] [ f ] if ; : (draw-cel-shaded-bunny) ( geom program -- ) @@ -85,8 +86,8 @@ TUPLE: bunny-cel-shaded program ; } [ bunny-geom ] with-gl-program ; M: bunny-cel-shaded draw-bunny - bunny-cel-shaded-program (draw-cel-shaded-bunny) ; + program>> (draw-cel-shaded-bunny) ; M: bunny-cel-shaded dispose - bunny-cel-shaded-program delete-gl-program ; + program>> delete-gl-program ; diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor index f3fb68e515..bf0fc45f0f 100644 --- a/extra/bunny/fixed-pipeline/fixed-pipeline.factor +++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor @@ -6,7 +6,7 @@ TUPLE: bunny-fixed-pipeline ; : ( gadget -- draw ) drop - { } bunny-fixed-pipeline construct ; + bunny-fixed-pipeline new ; M: bunny-fixed-pipeline draw-bunny drop diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 897a30c417..9598b8b03b 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii opengl.capabilities shuffle http.client vectors splitting tools.time system combinators -float-arrays continuations namespaces sequences.lib ; +float-arrays continuations namespaces sequences.lib accessors ; IN: bunny.model : numbers ( str -- seq ) @@ -85,24 +85,24 @@ M: bunny-dlist bunny-geom bunny-dlist-list glCallList ; M: bunny-buffers bunny-geom - dup { - bunny-buffers-array - bunny-buffers-element-array - } get-slots [ + dup { array>> element-array>> } get-slots [ { GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [ GL_DOUBLE 0 0 buffer-offset glNormalPointer - dup bunny-buffers-nv "double" heap-size * buffer-offset - 3 GL_DOUBLE 0 roll glVertexPointer - bunny-buffers-ni - GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements + [ + nv>> "double" heap-size * buffer-offset + 3 GL_DOUBLE 0 roll glVertexPointer + ] [ + ni>> + GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements + ] bi ] all-enabled-client-state ] with-array-element-buffers ; M: bunny-dlist dispose - bunny-dlist-list delete-dlist ; + list>> delete-dlist ; M: bunny-buffers dispose - { bunny-buffers-array bunny-buffers-element-array } get-slots + { array>> element-array>> } get-slots delete-gl-buffer delete-gl-buffer ; : ( model -- geom ) diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 9c4e8b22a2..fef57d95d2 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,6 +1,7 @@ USING: arrays bunny.model bunny.cel-shaded continuations kernel math multiline opengl opengl.shaders opengl.framebuffers -opengl.gl opengl.capabilities sequences ui.gadgets combinators ; +opengl.gl opengl.capabilities sequences ui.gadgets combinators +accessors ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source @@ -139,9 +140,9 @@ TUPLE: bunny-outlined : ( gadget -- draw ) outlining-supported? [ pass1-program pass2-program { - set-bunny-outlined-gadget - set-bunny-outlined-pass1-program - set-bunny-outlined-pass2-program + (>>gadget) + (>>pass1-program) + (>>pass2-program) } bunny-outlined construct ] [ drop f ] if ; @@ -169,34 +170,33 @@ TUPLE: bunny-outlined ] with-framebuffer ; : dispose-framebuffer ( draw -- ) - dup bunny-outlined-framebuffer-dim [ + dup framebuffer-dim>> [ { - [ bunny-outlined-framebuffer [ delete-framebuffer ] when* ] - [ bunny-outlined-color-texture [ delete-texture ] when* ] - [ bunny-outlined-normal-texture [ delete-texture ] when* ] - [ bunny-outlined-depth-texture [ delete-texture ] when* ] - [ f swap set-bunny-outlined-framebuffer-dim ] + [ framebuffer>> [ delete-framebuffer ] when* ] + [ color-texture>> [ delete-texture ] when* ] + [ normal-texture>> [ delete-texture ] when* ] + [ depth-texture>> [ delete-texture ] when* ] + [ f >>framebuffer-dim drop ] } cleave ] [ drop ] if ; : remake-framebuffer-if-needed ( draw -- ) - dup bunny-outlined-gadget rect-dim - over bunny-outlined-framebuffer-dim + dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi over = [ 2drop ] [ - swap dup dispose-framebuffer >r - dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) - swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) - swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture) - swap >r - [ (make-framebuffer) ] 3keep - r> r> { - set-bunny-outlined-framebuffer - set-bunny-outlined-color-texture - set-bunny-outlined-normal-texture - set-bunny-outlined-depth-texture - set-bunny-outlined-framebuffer-dim - } set-slots + [ dup dispose-framebuffer dup ] dip { + [ + GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) + [ >>color-texture drop ] keep + ] [ + GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) + [ >>normal-texture drop ] keep + ] [ + GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture) + [ >>depth-texture drop ] keep + ] + } 2cleave + (make-framebuffer) >>framebuffer drop ] if ; : clear-framebuffer ( -- ) @@ -208,23 +208,27 @@ TUPLE: bunny-outlined GL_COLOR_BUFFER_BIT glClear ; : (pass1) ( geom draw -- ) - dup bunny-outlined-framebuffer [ + dup framebuffer>> [ clear-framebuffer { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers - bunny-outlined-pass1-program (draw-cel-shaded-bunny) + pass1-program>> (draw-cel-shaded-bunny) ] with-framebuffer ; : (pass2) ( draw -- ) - init-matrices - dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit - dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit - dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit - bunny-outlined-pass2-program { - { "colormap" [ 0 glUniform1i ] } - { "normalmap" [ 1 glUniform1i ] } - { "depthmap" [ 2 glUniform1i ] } - { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] } - } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ; + init-matrices { + [ 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 ] + [ + pass2-program>> { + { "colormap" [ 0 glUniform1i ] } + { "normalmap" [ 1 glUniform1i ] } + { "depthmap" [ 2 glUniform1i ] } + { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] } + } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] + with-gl-program + ] + } cleave ; M: bunny-outlined draw-bunny [ remake-framebuffer-if-needed ] @@ -232,6 +236,6 @@ M: bunny-outlined draw-bunny [ (pass2) ] tri ; M: bunny-outlined dispose - [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] - [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] + [ pass1-program>> [ delete-gl-program ] when* ] + [ pass2-program>> [ delete-gl-program ] when* ] [ dispose-framebuffer ] tri ; From 03c4b6ee854eed4e60782a395d05e4ba950094fd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 21 Apr 2008 21:50:35 -0700 Subject: [PATCH 12/14] Minor adjustments to spheres demo --- extra/spheres/spheres.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor index 3975307280..9d06987bcd 100644 --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -105,7 +105,7 @@ TUPLE: spheres-gadget reflection-texture ; : ( -- gadget ) - 0.0 0.0 20.0 + 20.0 10.0 20.0 { set-delegate } spheres-gadget construct ; M: spheres-gadget near-plane ( gadget -- z ) @@ -116,7 +116,7 @@ M: spheres-gadget distance-step ( gadget -- dz ) drop 0.5 ; : (reflection-dim) ( -- w h ) - 1024 1024 ; + 512 512 ; : (make-reflection-texture) ( -- texture ) gen-texture [ @@ -268,10 +268,9 @@ M: spheres-gadget draw-gadget* ( gadget -- ) [ (draw-reflection-texture) ] [ demo-gadget-set-matrices ] [ sphere-scene ] + [ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ] [ - { texture-sphere-program>> reflection-texture>> } get-slots - GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit - dup { + texture-sphere-program>> dup { { "surface_texture" [ 0 glUniform1i ] } } [ { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) From 89df7fd1042879c5a7cb682e6757f293abe448c2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Apr 2008 18:48:39 -0700 Subject: [PATCH 13/14] Add missing USING: accessors vocab to demo-support --- extra/opengl/demo-support/demo-support.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index e98dcbce32..88531a70bc 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,6 +1,6 @@ USING: arrays combinators.lib kernel math math.functions math.order math.vectors namespaces opengl opengl.gl sequences ui -ui.gadgets ui.gestures ui.render ; +ui.gadgets ui.gestures ui.render accessors ; IN: opengl.demo-support : FOV 2.0 sqrt 1+ ; inline From 1f7be9945b5e0ade605c3a9eafed9d3360986307 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 28 Apr 2008 14:52:03 -0500 Subject: [PATCH 14/14] Cleanup erg's cleanup --- core/kernel/kernel-docs.factor | 16 +++------------- core/math/order/order-docs.factor | 23 +++++++++++++++++++---- core/math/order/order.factor | 6 ++++-- core/sorting/sorting-docs.factor | 2 ++ extra/help/handbook/handbook.factor | 1 + 5 files changed, 29 insertions(+), 19 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 6862232f2d..0ef8919713 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -1,5 +1,5 @@ USING: generic help.markup help.syntax math memory -namespaces sequences kernel.private layouts sorting classes +namespaces sequences kernel.private layouts classes kernel.private vectors combinators quotations strings words assocs arrays math.order ; IN: kernel @@ -241,7 +241,7 @@ ARTICLE: "conditionals" "Conditionals and logic" "See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches." { $see-also "booleans" "bitwise-arithmetic" both? either? } ; -ARTICLE: "equality" "Equality and comparison testing" +ARTICLE: "equality" "Equality" "There are two distinct notions of ``sameness'' when it comes to objects. You can test if two references point to the same object (" { $emphasis "identity comparison" } "), or you can test if two objects are equal in a domain-specific sense, usually by being instances of the same class, and having equal slot values (" { $emphasis "value comparison" } "). Both notions of equality are equality relations in the mathematical sense." $nl "Identity comparison:" @@ -250,16 +250,8 @@ $nl { $subsection = } "Custom value comparison methods:" { $subsection equal? } +"Utility class:" { $subsection identity-tuple } -"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":" -{ $subsection <=> } -{ $subsection compare } -{ $subsection invert-comparison } -"Utilities for comparing objects:" -{ $subsection after? } -{ $subsection before? } -{ $subsection after=? } -{ $subsection before=? } "An object can be cloned; the clone has distinct identity but equal value:" { $subsection clone } ; @@ -394,8 +386,6 @@ HELP: identity-tuple { $unchecked-example "T{ foo } dup clone = ." "f" } } ; -{ <=> compare natural-sort sort-keys sort-values } related-words - HELP: clone { $values { "obj" object } { "cloned" "a new object" } } { $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ; diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index b761959a83..98ff1920fa 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -1,9 +1,9 @@ -USING: help.markup help.syntax kernel math sequences quotations -math.private ; +USING: help.markup help.syntax kernel math quotations +math.private words ; IN: math.order HELP: <=> -{ $values { "obj1" object } { "obj2" object } { "n" real } } +{ $values { "obj1" object } { "obj2" object } { "symbol" symbol } } { $contract "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings." $nl @@ -13,7 +13,6 @@ HELP: <=> { { $link +eq+ } " - indicating that " { $snippet "obj1" } " is equal to " { $snippet "obj2" } } { { $link +gt+ } " - indicating that " { $snippet "obj1" } " follows " { $snippet "obj2" } } } - "The default implementation treats the two objects as sequences, and recursively compares their elements. So no extra work is required to compare sequences lexicographically." } ; HELP: +lt+ @@ -77,3 +76,19 @@ HELP: [-] { $values { "x" real } { "y" real } { "z" real } } { $description "Subtracts " { $snippet "y" } " from " { $snippet "x" } ". If the result is less than zero, outputs zero." } ; +ARTICLE: "math.order" "Ordered objects" +"Some classes have an intrinsic order amongst instances:" +{ $subsection <=> } +{ $subsection compare } +{ $subsection invert-comparison } +"The above words return one of the following symbols:" +{ $subsection +lt+ } +{ $subsection +eq+ } +{ $subsection +gt+ } +"Utilities for comparing objects:" +{ $subsection after? } +{ $subsection before? } +{ $subsection after=? } +{ $subsection before=? } ; + +ABOUT: "math.order" diff --git a/core/math/order/order.factor b/core/math/order/order.factor index 36624f5ca9..aa597bbaad 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -7,11 +7,13 @@ SYMBOL: +lt+ SYMBOL: +eq+ SYMBOL: +gt+ -GENERIC: <=> ( obj1 obj2 -- n ) +GENERIC: <=> ( obj1 obj2 -- symbol ) -: (<=>) - dup 0 < [ drop +lt+ ] [ zero? +eq+ +gt+ ? ] if ; +: (<=>) ( a b -- symbol ) + 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; inline : invert-comparison ( symbol -- new-symbol ) + #! Can't use case, index or nth here dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ; M: real <=> (<=>) ; diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index 3da6ea6bd6..5827a711c8 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -62,3 +62,5 @@ HELP: binsearch* { $description "Variant of " { $link binsearch } " which outputs the found element rather than its index in the sequence." $nl "Outputs " { $link f } " if the sequence is empty. If the sequence has at least one element, this word always outputs a sequence element." } ; + +{ <=> compare natural-sort sort-keys sort-values } related-words diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 7babaec7f6..ce875b32d1 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -104,6 +104,7 @@ $nl ARTICLE: "objects" "Objects" "An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed." { $subsection "equality" } +{ $subsection "math.order" } { $subsection "classes" } { $subsection "tuples" } { $subsection "generic" }