-{
- IBClasses = (
- {
- ACTIONS = {
- newFactorWorkspace = id;
- runFactorFile = id;
- saveFactorImage = id;
- saveFactorImageAs = id;
- showFactorHelp = id;
- };
- CLASS = FirstResponder;
- LANGUAGE = ObjC;
- SUPERCLASS = NSObject;
- }
- );
- IBVersion = 1;
-}
\ No newline at end of file
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>IBClasses</key>
+ <array>
+ <dict>
+ <key>ACTIONS</key>
+ <dict>
+ <key>factorBrowser</key>
+ <string>id</string>
+ <key>factorListener</key>
+ <string>id</string>
+ <key>newFactorBrowser</key>
+ <string>id</string>
+ <key>newFactorListener</key>
+ <string>id</string>
+ <key>refreshAll</key>
+ <string>id</string>
+ <key>runFactorFile</key>
+ <string>id</string>
+ <key>saveFactorImage</key>
+ <string>id</string>
+ <key>saveFactorImageAs</key>
+ <string>id</string>
+ </dict>
+ <key>CLASS</key>
+ <string>FirstResponder</string>
+ <key>LANGUAGE</key>
+ <string>ObjC</string>
+ <key>SUPERCLASS</key>
+ <string>NSObject</string>
+ </dict>
+ </array>
+ <key>IBVersion</key>
+ <string>1</string>
+</dict>
+</plist>
<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
- <key>IBDocumentLocation</key>
- <string>557 119 525 491 0 0 2560 1578 </string>
- <key>IBEditorPositions</key>
- <dict>
- <key>29</key>
- <string>326 905 270 44 0 0 2560 1578 </string>
- </dict>
<key>IBFramework Version</key>
- <string>439.0</string>
+ <string>629</string>
+ <key>IBOldestOS</key>
+ <integer>5</integer>
<key>IBOpenObjects</key>
<array>
- <integer>29</integer>
+ <integer>305</integer>
</array>
<key>IBSystem Version</key>
- <string>8R218</string>
+ <string>9G55</string>
+ <key>targetFramework</key>
+ <string>IBCocoaFramework</string>
</dict>
</plist>
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.destructors ;
+IN: alien.destructors.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors destructors accessors kernel parser words ;
+IN: alien.destructors
+
+SLOT: alien
+
+FUNCTOR: define-destructor ( F -- )
+
+F-destructor DEFINES ${F}-destructor
+<F-destructor> DEFINES <${F}-destructor>
+&F DEFINES &${F}
+|F DEFINES |${F}
+
+WHERE
+
+TUPLE: F-destructor alien disposed ;
+
+: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
+
+M: F-destructor dispose* alien>> F ;
+
+: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
+
+: |F ( alien -- alien ) dup <F-destructor> |dispose drop ; inline
+
+;FUNCTOR
+
+: DESTRUCTOR: scan-word define-destructor ; parsing
\ No newline at end of file
--- /dev/null
+Functor for defining destructors which call a C function to dispose of resources
-! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
+! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
[ "bootstrap." prepend vocab ] all? [
"ui.tools" require
- "ui.cocoa" vocab [
- "ui.cocoa.tools" require
+ "ui.backend.cocoa" vocab [
+ "ui.backend.cocoa.tools" require
] when
"ui.tools.walker" require
{ [ os windows? ] [ "windows" ] }
{ [ os unix? ] [ "x11" ] }
} cond
- ] unless* "ui." prepend require
+ ] unless* "ui.backend." prepend require
- "ui.freetype" require
+ "ui-text-backend" get [
+ {
+ { [ os macosx? ] [ "core-text" ] }
+ { [ os windows? ] [ "freetype" ] }
+ { [ os unix? ] [ "freetype" ] }
+ } cond
+ ] unless* "ui.text." prepend require
] when
{ <NSString> <CFString> CF>string } related-words
-HELP: <NSArray>
-{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" alien } }
-{ $description "Allocates an autoreleased " { $snippet "CFArray" } "." } ;
-
-{ <NSArray> <CFArray> } related-words
-
HELP: with-autorelease-pool
{ $values { "quot" quotation } }
{ $description "Sets up a new " { $snippet "NSAutoreleasePool" } ", calls the quotation and frees the pool." } ;
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
-core-foundation.arrays core-foundation.data
core-foundation.strings cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads init summary kernel.private
assocs ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
-: <NSArray> ( seq -- alien ) <CFArray> -> autorelease ;
-: <NSNumber> ( number -- alien ) <CFNumber> -> autorelease ;
-: <NSData> ( byte-array -- alien ) <CFData> -> autorelease ;
-: <NSDictionary> ( assoc -- alien )
- NSMutableDictionary over assoc-size -> dictionaryWithCapacity:
- [
- [
- spin -> setObject:forKey:
- ] curry assoc-each
- ] keep ;
-: NSApplicationDelegateReplySuccess 0 ;
-: NSApplicationDelegateReplyCancel 1 ;
-: NSApplicationDelegateReplyFailure 2 ;
+C-ENUM:
+NSApplicationDelegateReplySuccess
+NSApplicationDelegateReplyCancel
+NSApplicationDelegateReplyFailure ;
: with-autorelease-pool ( quot -- )
NSAutoreleasePool -> new slip -> release ; inline
[ NSNotificationCenter -> defaultCenter ] dip
-> removeObserver: ;
-: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
+: cocoa-app ( quot -- )
+ [ call NSApp -> run ] with-cocoa ; inline
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
{ $subsection "objc-calling" }
{ $subsection "objc-subclassing" }
"A utility library is built to faciliate the development of Cocoa applications in Factor:"
-{ $subsection "cocoa-types" }
{ $subsection "cocoa-application-utils" }
{ $subsection "cocoa-dialogs" }
{ $subsection "cocoa-pasteboard-utils" }
IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
-compiler.units math ;
+compiler.units math core-graphics.types ;
CLASS: {
{ +superclass+ "NSObject" }
: test-foo
Foo -> alloc -> init
- dup 1.0 2.0 101.0 102.0 <NSRect> -> foo:
+ dup 1.0 2.0 101.0 102.0 <CGRect> -> foo:
-> release ;
test-foo
-[ 1.0 ] [ "x" get NSRect-x ] unit-test
-[ 2.0 ] [ "x" get NSRect-y ] unit-test
-[ 101.0 ] [ "x" get NSRect-w ] unit-test
-[ 102.0 ] [ "x" get NSRect-h ] unit-test
+[ 1.0 ] [ "x" get CGRect-x ] unit-test
+[ 2.0 ] [ "x" get CGRect-y ] unit-test
+[ 101.0 ] [ "x" get CGRect-w ] unit-test
+[ 102.0 ] [ "x" get CGRect-h ] unit-test
CLASS: {
{ +superclass+ "NSObject" }
-> release
] compile-call
-[ 1.0 ] [ "x" get NSRect-x ] unit-test
-[ 2.0 ] [ "x" get NSRect-y ] unit-test
-[ 101.0 ] [ "x" get NSRect-w ] unit-test
-[ 102.0 ] [ "x" get NSRect-h ] unit-test
+[ 1.0 ] [ "x" get CGRect-x ] unit-test
+[ 2.0 ] [ "x" get CGRect-y ] unit-test
+[ 101.0 ] [ "x" get CGRect-w ] unit-test
+[ 102.0 ] [ "x" get CGRect-h ] unit-test
! Make sure that we can add methods
CLASS: {
: NS-EACH-BUFFER-SIZE 16 ; inline
: with-enumeration-buffers ( quot -- )
- [
- [
- "NSFastEnumerationState" malloc-object &free
- NS-EACH-BUFFER-SIZE "id" heap-size * malloc-object &free
- NS-EACH-BUFFER-SIZE
- ] dip call
+ '[
+ "NSFastEnumerationState" malloc-object &free
+ NS-EACH-BUFFER-SIZE "id" malloc-array &free
+ NS-EACH-BUFFER-SIZE
+ @
] with-destructors ; inline
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
continuations combinators compiler compiler.alien kernel math
drop "void*"
] unless ;
+ERROR: no-objc-type name ;
+
+: decode-type ( ch -- ctype )
+ 1string dup objc>alien-types get at
+ [ ] [ no-objc-type ] ?if ;
+
: (parse-objc-type) ( i string -- ctype )
[ [ 1+ ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
- [ 2nip 1string objc>alien-types get at ]
+ [ 2nip decode-type ]
} cond ;
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors arrays kernel cocoa.messages
cocoa.classes cocoa.application sequences cocoa core-foundation
dup [ CF>string ] when ;
: set-pasteboard-types ( seq pasteboard -- )
- swap <NSArray> f -> declareTypes:owner: drop ;
+ swap <CFArray> -> autorelease f -> declareTypes:owner: drop ;
: set-pasteboard-string ( str pasteboard -- )
NSStringPboardType <NSString>
--- /dev/null
+IN: cocoa.plists.tests
+USING: tools.test cocoa.plists colors kernel hashtables
+core-foundation.utilities core-foundation destructors
+assocs cocoa.enumeration ;
+
+[
+ [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
+ [ V{ "A" } ] [ { "A" } >cf &CFRelease plist> ] unit-test
+ [ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
+] with-destructors
\ No newline at end of file
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: strings arrays hashtables assocs sequences
+USING: strings arrays hashtables assocs sequences fry macros
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types core-foundation core-foundation.data ;
+combinators alien.c-types words core-foundation
+core-foundation.data core-foundation.utilities ;
IN: cocoa.plists
-GENERIC: >plist ( value -- plist )
-
-M: number >plist
- <NSNumber> ;
-M: t >plist
- <NSNumber> ;
-M: f >plist
- <NSNumber> ;
-M: string >plist
- <NSString> ;
-M: byte-array >plist
- <NSData> ;
-M: hashtable >plist
- [ [ >plist ] bi@ ] assoc-map <NSDictionary> ;
-M: sequence >plist
- [ >plist ] map <NSArray> ;
+: >plist ( value -- plist ) >cf -> autorelease ;
: write-plist ( assoc path -- )
- [ >plist ] [ normalize-path <NSString> ] bi* 0
- -> writeToFile:atomically:
+ [ >plist ] [ normalize-path <NSString> ] bi* 0 -> writeToFile:atomically:
[ "write-plist failed" throw ] unless ;
DEFER: plist>
+<PRIVATE
+
: (plist-NSString>) ( NSString -- string )
-> UTF8String ;
: (plist-NSNumber>) ( NSNumber -- number )
dup -> doubleValue dup >integer =
- [ -> longLongValue ]
- [ -> doubleValue ] if ;
+ [ -> longLongValue ] [ -> doubleValue ] if ;
: (plist-NSData>) ( NSData -- byte-array )
dup -> length <byte-array> [ -> getBytes: ] keep ;
: (plist-NSArray>) ( NSArray -- vector )
- [ plist> ] NSFastEnumeration-map ;
+ [ plist> ] NSFastEnumeration-map ;
: (plist-NSDictionary>) ( NSDictionary -- hashtable )
- dup [ [ -> valueForKey: ] keep swap [ plist> ] bi@ 2array ] with
+ dup [ tuck -> valueForKey: [ plist> ] bi@ 2array ] with
NSFastEnumeration-map >hashtable ;
-: plist> ( plist -- value )
- {
- { [ dup NSString -> isKindOfClass: c-bool> ] [ (plist-NSString>) ] }
- { [ dup NSNumber -> isKindOfClass: c-bool> ] [ (plist-NSNumber>) ] }
- { [ dup NSData -> isKindOfClass: c-bool> ] [ (plist-NSData>) ] }
- { [ dup NSArray -> isKindOfClass: c-bool> ] [ (plist-NSArray>) ] }
- { [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] }
- [ ]
- } cond ;
-
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f f <void*>
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
*void* [ -> release "read-plist failed" throw ] when* ;
+MACRO: objc-class-case ( alist -- quot )
+ [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
+
+PRIVATE>
+
+: plist> ( plist -- value )
+ {
+ { NSString [ (plist-NSString>) ] }
+ { NSNumber [ (plist-NSNumber>) ] }
+ { NSData [ (plist-NSData>) ] }
+ { NSArray [ (plist-NSArray>) ] }
+ { NSDictionary [ (plist-NSDictionary>) ] }
+ { NSObject [ ] }
+ } objc-class-case ;
+
: read-plist ( path -- assoc )
normalize-path <NSString>
NSData swap -> dataWithContentsOfFile:
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
+: encode-type ( type -- encoded )
+ dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
+
: encode-types ( return types -- encoding )
- swap prefix [
- alien>objc-types get at "0" append
- ] map concat ;
+ swap prefix [ encode-type "0" append ] map concat ;
: prepare-method ( ret types quot -- type imp )
[ [ encode-types ] 2keep ] dip [
+++ /dev/null
-USING: math help.markup help.syntax ;
-IN: cocoa.types
-
-HELP: <NSRect>
-{ $values { "x" real } { "y" real } { "w" real } { "h" real } { "rect" "an " { $snippet "NSRect" } } }
-{ $description "Allocates a new " { $snippet "NSRect" } " in the Factor heap." } ;
-
-HELP: <NSPoint>
-{ $values { "x" real } { "y" real } { "point" "an " { $snippet "NSPoint" } } }
-{ $description "Allocates a new " { $snippet "NSPoint" } " in the Factor heap." } ;
-
-HELP: <NSSize>
-{ $values { "w" real } { "h" real } { "size" "an " { $snippet "NSSize" } } }
-{ $description "Allocates a new " { $snippet "NSSize" } " in the Factor heap." } ;
-
-ARTICLE: "cocoa-types" "Cocoa types"
-"The Cocoa binding defines some common C structs:"
-{ $code
- "NSRect"
- "NSPoint"
- "NSSize"
-}
-"Some words for working with the above:"
-{ $subsection <NSRect> }
-{ $subsection <NSPoint> }
-{ $subsection <NSSize> } ;
-
-IN: cocoa.types
-ABOUT: "cocoa-types"
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax combinators kernel ;
+USING: alien.c-types alien.syntax combinators kernel layouts
+core-graphics.types ;
IN: cocoa.types
TYPEDEF: long NSInteger
TYPEDEF: ulong NSUInteger
-<< "ptrdiff_t" heap-size {
- { 4 [ "float" ] }
- { 8 [ "double" ] }
-} case "CGFloat" typedef >>
-
-C-STRUCT: NSPoint
- { "CGFloat" "x" }
- { "CGFloat" "y" } ;
+TYPEDEF: CGPoint NSPoint
TYPEDEF: NSPoint _NSPoint
-TYPEDEF: NSPoint CGPoint
-
-: <NSPoint> ( x y -- point )
- "NSPoint" <c-object>
- [ set-NSPoint-y ] keep
- [ set-NSPoint-x ] keep ;
-
-C-STRUCT: NSSize
- { "CGFloat" "w" }
- { "CGFloat" "h" } ;
+TYPEDEF: CGSize NSSize
TYPEDEF: NSSize _NSSize
-TYPEDEF: NSSize CGSize
-
-: <NSSize> ( w h -- size )
- "NSSize" <c-object>
- [ set-NSSize-h ] keep
- [ set-NSSize-w ] keep ;
-
-C-STRUCT: NSRect
- { "NSPoint" "origin" }
- { "NSSize" "size" } ;
+TYPEDEF: CGRect NSRect
TYPEDEF: NSRect _NSRect
-TYPEDEF: NSRect CGRect
-
-: NSRect-x ( NSRect -- x )
- NSRect-origin NSPoint-x ; inline
-: NSRect-y ( NSRect -- y )
- NSRect-origin NSPoint-y ; inline
-: NSRect-w ( NSRect -- w )
- NSRect-size NSSize-w ; inline
-: NSRect-h ( NSRect -- h )
- NSRect-size NSSize-h ; inline
-
-: set-NSRect-x ( x NSRect -- )
- NSRect-origin set-NSPoint-x ; inline
-: set-NSRect-y ( y NSRect -- )
- NSRect-origin set-NSPoint-y ; inline
-: set-NSRect-w ( w NSRect -- )
- NSRect-size set-NSSize-w ; inline
-: set-NSRect-h ( h NSRect -- )
- NSRect-size set-NSSize-h ; inline
-
-: <NSRect> ( x y w h -- rect )
- "NSRect" <c-object>
- [ set-NSRect-h ] keep
- [ set-NSRect-w ] keep
- [ set-NSRect-y ] keep
- [ set-NSRect-x ] keep ;
-
-: NSRect-x-y ( alien -- origin-x origin-y )
- [ NSRect-x ] keep NSRect-y ;
C-STRUCT: NSRange
{ "NSUInteger" "location" }
[ set-NSRange-length ] keep
[ set-NSRange-location ] keep ;
-C-STRUCT: CGAffineTransform
- { "CGFloat" "a" }
- { "CGFloat" "b" }
- { "CGFloat" "c" }
- { "CGFloat" "d" }
- { "CGFloat" "tx" }
- { "CGFloat" "ty" } ;
-
C-STRUCT: NSFastEnumerationState
{ "ulong" "state" }
{ "id*" "itemsPtr" }
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: specialized-arrays.int arrays kernel math namespaces make
-cocoa cocoa.messages cocoa.classes cocoa.types sequences
+cocoa cocoa.messages cocoa.classes core-graphics.types sequences
continuations accessors ;
IN: cocoa.views
-: NSOpenGLPFAAllRenderers 1 ;
-: NSOpenGLPFADoubleBuffer 5 ;
-: NSOpenGLPFAStereo 6 ;
-: NSOpenGLPFAAuxBuffers 7 ;
-: NSOpenGLPFAColorSize 8 ;
-: NSOpenGLPFAAlphaSize 11 ;
-: NSOpenGLPFADepthSize 12 ;
-: NSOpenGLPFAStencilSize 13 ;
-: NSOpenGLPFAAccumSize 14 ;
-: NSOpenGLPFAMinimumPolicy 51 ;
-: NSOpenGLPFAMaximumPolicy 52 ;
-: NSOpenGLPFAOffScreen 53 ;
-: NSOpenGLPFAFullScreen 54 ;
-: NSOpenGLPFASampleBuffers 55 ;
-: NSOpenGLPFASamples 56 ;
-: NSOpenGLPFAAuxDepthStencil 57 ;
-: NSOpenGLPFAColorFloat 58 ;
-: NSOpenGLPFAMultisample 59 ;
-: NSOpenGLPFASupersample 60 ;
-: NSOpenGLPFASampleAlpha 61 ;
-: NSOpenGLPFARendererID 70 ;
-: NSOpenGLPFASingleRenderer 71 ;
-: NSOpenGLPFANoRecovery 72 ;
-: NSOpenGLPFAAccelerated 73 ;
-: NSOpenGLPFAClosestPolicy 74 ;
-: NSOpenGLPFARobust 75 ;
-: NSOpenGLPFABackingStore 76 ;
-: NSOpenGLPFAMPSafe 78 ;
-: NSOpenGLPFAWindow 80 ;
-: NSOpenGLPFAMultiScreen 81 ;
-: NSOpenGLPFACompliant 83 ;
-: NSOpenGLPFAScreenMask 84 ;
-: NSOpenGLPFAPixelBuffer 90 ;
-: NSOpenGLPFAAllowOfflineRenderers 96 ;
-: NSOpenGLPFAVirtualScreenCount 128 ;
-
-: kCGLRendererGenericFloatID HEX: 00020400 ;
+CONSTANT: NSOpenGLPFAAllRenderers 1
+CONSTANT: NSOpenGLPFADoubleBuffer 5
+CONSTANT: NSOpenGLPFAStereo 6
+CONSTANT: NSOpenGLPFAAuxBuffers 7
+CONSTANT: NSOpenGLPFAColorSize 8
+CONSTANT: NSOpenGLPFAAlphaSize 11
+CONSTANT: NSOpenGLPFADepthSize 12
+CONSTANT: NSOpenGLPFAStencilSize 13
+CONSTANT: NSOpenGLPFAAccumSize 14
+CONSTANT: NSOpenGLPFAMinimumPolicy 51
+CONSTANT: NSOpenGLPFAMaximumPolicy 52
+CONSTANT: NSOpenGLPFAOffScreen 53
+CONSTANT: NSOpenGLPFAFullScreen 54
+CONSTANT: NSOpenGLPFASampleBuffers 55
+CONSTANT: NSOpenGLPFASamples 56
+CONSTANT: NSOpenGLPFAAuxDepthStencil 57
+CONSTANT: NSOpenGLPFAColorFloat 58
+CONSTANT: NSOpenGLPFAMultisample 59
+CONSTANT: NSOpenGLPFASupersample 60
+CONSTANT: NSOpenGLPFASampleAlpha 61
+CONSTANT: NSOpenGLPFARendererID 70
+CONSTANT: NSOpenGLPFASingleRenderer 71
+CONSTANT: NSOpenGLPFANoRecovery 72
+CONSTANT: NSOpenGLPFAAccelerated 73
+CONSTANT: NSOpenGLPFAClosestPolicy 74
+CONSTANT: NSOpenGLPFARobust 75
+CONSTANT: NSOpenGLPFABackingStore 76
+CONSTANT: NSOpenGLPFAMPSafe 78
+CONSTANT: NSOpenGLPFAWindow 80
+CONSTANT: NSOpenGLPFAMultiScreen 81
+CONSTANT: NSOpenGLPFACompliant 83
+CONSTANT: NSOpenGLPFAScreenMask 84
+CONSTANT: NSOpenGLPFAPixelBuffer 90
+CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
+CONSTANT: NSOpenGLPFAVirtualScreenCount 128
+
+CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
+
+
+CONSTANT: NSOpenGLCPSwapInterval 222
<PRIVATE
-SYMBOL: +software-renderer+
-SYMBOL: +multisample+
+SYMBOL: software-renderer?
+SYMBOL: multisample?
PRIVATE>
: with-software-renderer ( quot -- )
- t +software-renderer+ pick with-variable ; inline
+ [ t software-renderer? ] dip with-variable ; inline
+
: with-multisample ( quot -- )
- t +multisample+ pick with-variable ; inline
+ [ t multisample? ] dip with-variable ; inline
: <PixelFormat> ( attributes -- pixelfmt )
NSOpenGLPixelFormat -> alloc swap [
%
NSOpenGLPFADepthSize , 16 ,
- +software-renderer+ get [
+ software-renderer? get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
] when
- +multisample+ get [
+ multisample? get [
NSOpenGLPFASupersample ,
NSOpenGLPFASampleBuffers , 1 ,
NSOpenGLPFASamples , 8 ,
-> autorelease ;
: <GLView> ( class dim -- view )
- [ -> alloc 0 0 ] dip first2 <NSRect>
+ [ -> alloc 0 0 ] dip first2 <CGRect>
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
: view-dim ( view -- dim )
-> bounds
- dup NSRect-w >fixnum
- swap NSRect-h >fixnum 2array ;
+ [ CGRect-w >fixnum ] [ CGRect-h >fixnum ] bi
+ 2array ;
: mouse-location ( view event -- loc )
[
-> locationInWindow f -> convertPoint:fromView:
- [ NSPoint-x ] [ NSPoint-y ] bi
- ] [ drop -> frame NSRect-h ] 2bi
+ [ CGPoint-x ] [ CGPoint-y ] bi
+ ] [ drop -> frame CGRect-h ] 2bi
swap - 2array ;
-
-USE: opengl.gl
-USE: alien.syntax
-
-: NSOpenGLCPSwapInterval 222 ;
-
-LIBRARY: OpenGL
-
-TYPEDEF: int CGLError
-TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
-
-FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
-
--- /dev/null
+IN: colors
+USING: accessors help.markup help.syntax ;
+
+HELP: color
+{ $class-description "The class of colors. Implementations include " { $link rgba } ", " { $link "colors.gray" } " and " { $vocab-link "colors.hsv" } "." } ;
+
+HELP: rgba
+{ $class-description "The class of colors with red, green, blue and alpha channel components. The slots store color components, which are real numbers in the range 0 to 1, inclusive." } ;
+
+HELP: >rgba
+{ $values { "color" color } { "rgba" rgba } }
+{ $contract "Converts a color to an RGBA color." } ;
+
+ARTICLE: "colors.standard" "Standard colors"
+"A few useful constants:"
+{ $subsection black }
+{ $subsection blue }
+{ $subsection cyan }
+{ $subsection gray }
+{ $subsection dark-gray }
+{ $subsection green }
+{ $subsection light-gray }
+{ $subsection light-purple }
+{ $subsection medium-purple }
+{ $subsection magenta }
+{ $subsection orange }
+{ $subsection purple }
+{ $subsection red }
+{ $subsection white }
+{ $subsection yellow } ;
+
+ARTICLE: "colors.protocol" "Color protocol"
+"Abstract superclass for colors:"
+{ $subsection color }
+"All color objects must are required to implement a method on the " { $link >rgba } " generic word."
+$nl
+"Optionally, they can provide methods on the accessors " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " and " { $link alpha>> } ", either by defining slots with the appropriate names, or with methods which calculate the color component values. The accessors should return color components which are real numbers in the range between 0 and 1."
+$nl
+"Overriding the accessors is purely an optimization, since the default implementations call " { $link >rgba } " and then extract the appropriate component of the result." ;
+
+ARTICLE: "colors" "Colors"
+"The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them."
+$nl
+"RGBA colors:"
+{ $subsection rgba }
+{ $subsection <rgba> }
+"Converting a color to RGBA:"
+{ $subsection >rgba }
+"Extracting RGBA components of colors:"
+{ $subsection >rgba-components }
+"Further topics:"
+{ $subsection "colors.protocol" }
+{ $subsection "colors.standard" }
+{ $subsection "colors.gray" }
+{ $vocab-subsection "HSV colors" "colors.hsv" } ;
+
+ABOUT: "colors"
\ No newline at end of file
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors ;
+USING: kernel accessors combinators ;
IN: colors
TUPLE: color ;
C: <rgba> rgba
-GENERIC: >rgba ( object -- rgba )
+GENERIC: >rgba ( color -- rgba )
M: rgba >rgba ( rgba -- rgba ) ;
-M: color red>> ( color -- red ) >rgba red>> ;
+M: color red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ;
-M: color blue>> ( color -- blue ) >rgba blue>> ;
-
-: black T{ rgba f 0.0 0.0 0.0 1.0 } ; inline
-: blue T{ rgba f 0.0 0.0 1.0 1.0 } ; inline
-: cyan T{ rgba f 0 0.941 0.941 1 } ; inline
-: gray T{ rgba f 0.6 0.6 0.6 1.0 } ; inline
-: green T{ rgba f 0.0 1.0 0.0 1.0 } ; inline
-: light-gray T{ rgba f 0.95 0.95 0.95 0.95 } ; inline
-: light-purple T{ rgba f 0.8 0.8 1.0 1.0 } ; inline
-: magenta T{ rgba f 0.941 0 0.941 1 } ; inline
-: orange T{ rgba f 0.941 0.627 0 1 } ; inline
-: purple T{ rgba f 0.627 0 0.941 1 } ; inline
-: red T{ rgba f 1.0 0.0 0.0 1.0 } ; inline
-: white T{ rgba f 1.0 1.0 1.0 1.0 } ; inline
-: yellow T{ rgba f 1.0 1.0 0.0 1.0 } ; inline
+M: color blue>> ( color -- blue ) >rgba blue>> ;
+
+: >rgba-components ( object -- r g b a )
+ >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
+
+CONSTANT: black T{ rgba f 0.0 0.0 0.0 1.0 }
+CONSTANT: blue T{ rgba f 0.0 0.0 1.0 1.0 }
+CONSTANT: cyan T{ rgba f 0 0.941 0.941 1 }
+CONSTANT: gray T{ rgba f 0.6 0.6 0.6 1.0 }
+CONSTANT: dark-gray T{ rgba f 0.8 0.8 0.8 1.0 }
+CONSTANT: green T{ rgba f 0.0 1.0 0.0 1.0 }
+CONSTANT: light-gray T{ rgba f 0.95 0.95 0.95 0.95 }
+CONSTANT: light-purple T{ rgba f 0.8 0.8 1.0 1.0 }
+CONSTANT: medium-purple T{ rgba f 0.7 0.7 0.9 1.0 }
+CONSTANT: magenta T{ rgba f 0.941 0 0.941 1 }
+CONSTANT: orange T{ rgba f 0.941 0.627 0 1 }
+CONSTANT: purple T{ rgba f 0.627 0 0.941 1 }
+CONSTANT: red T{ rgba f 1.0 0.0 0.0 1.0 }
+CONSTANT: white T{ rgba f 1.0 1.0 1.0 1.0 }
+CONSTANT: yellow T{ rgba f 1.0 1.0 0.0 1.0 }
--- /dev/null
+USING: help.markup help.syntax accessors ;
+IN: colors.gray
+
+ARTICLE: "colors.gray" "Grayscale colors"
+"The " { $vocab-link "colors.gray" } " vocabulary implements grayscale colors. These colors hold a single value, and respond to " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " with that value. They also have an independent alpha channel, " { $link alpha>> } "."
+{ $subsection gray }
+{ $subsection <gray> } ;
+
+ABOUT: "colors.gray"
\ No newline at end of file
M: gray >rgba ( gray -- rgba )
[ gray>> dup dup ] [ alpha>> ] bi <rgba> ;
+
+M: gray red>> gray>> ;
+
+M: gray green>> gray>> ;
+
+M: gray blue>> gray>> ;
\ No newline at end of file
--- /dev/null
+IN: colors.hsv
+USING: help.markup help.syntax ;
+
+HELP: hsva
+{ $class-description "The class of HSV (Hue, Saturation, Value) colors with an alpha channel. The " { $slot "hue" } " slot stores a value in the interval " { $snippet "[0,360]" } " and the remaining slots store values in the interval " { $snippet "[0,1]" } "." } ;
+
+ARTICLE: "colors.hsv" "HSV colors"
+"The " { $vocab-link "colors.hsv" } " vocabulary implements colors specified by their hue, saturation, and value, together with an alpha channel."
+{ $subsection hsva }
+{ $subsection <hsva> }
+{ $see-also "colors" } ;
+
+ABOUT: "colors.hsv"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation.attributed-strings
+core-foundation ;
+IN: core-foundation.attributed-strings.tests
+
+[ ] [ "Hello world" H{ } <CFAttributedString> CFRelease ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel destructors core-foundation
+core-foundation.utilities ;
+IN: core-foundation.attributed-strings
+
+TYPEDEF: void* CFAttributedStringRef
+
+FUNCTION: CFAttributedStringRef CFAttributedStringCreate (
+ CFAllocatorRef alloc,
+ CFStringRef str,
+ CFDictionaryRef attributes
+) ;
+
+: <CFAttributedString> ( string assoc -- alien )
+ [
+ [ >cf &CFRelease ] bi@
+ [ kCFAllocatorDefault ] 2dip CFAttributedStringCreate
+ ] with-destructors ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax destructors accessors kernel ;
+USING: alien.syntax alien.c-types alien.destructors accessors kernel ;
IN: core-foundation
TYPEDEF: void* CFTypeRef
TYPEDEF: void* CFAllocatorRef
-: kCFAllocatorDefault f ; inline
+CONSTANT: kCFAllocatorDefault f
TYPEDEF: bool Boolean
TYPEDEF: long CFIndex
+TYPEDEF: char UInt8
TYPEDEF: int SInt32
TYPEDEF: uint UInt32
TYPEDEF: ulong CFTypeID
TYPEDEF: UInt32 CFOptionFlags
TYPEDEF: void* CFUUIDRef
-FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
+ALIAS: <CFIndex> <long>
+ALIAS: *CFIndex *long
-FUNCTION: void CFRelease ( CFTypeRef cf ) ;
+C-STRUCT: CFRange
+{ "CFIndex" "location" }
+{ "CFIndex" "length" } ;
-TUPLE: CFRelease-destructor alien disposed ;
+: <CFRange> ( location length -- range )
+ "CFRange" <c-object>
+ [ set-CFRange-length ] keep
+ [ set-CFRange-location ] keep ;
-M: CFRelease-destructor dispose* alien>> CFRelease ;
+FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
-: &CFRelease ( alien -- alien )
- dup f CFRelease-destructor boa &dispose drop ; inline
+FUNCTION: void CFRelease ( CFTypeRef cf ) ;
-: |CFRelease ( alien -- alien )
- dup f CFRelease-destructor boa |dispose drop ; inline
+DESTRUCTOR: CFRelease
\ No newline at end of file
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.c-types sequences kernel math ;
+USING: alien.c-types alien.syntax core-foundation.numbers kernel math
+sequences core-foundation.numbers ;
IN: core-foundation.data
TYPEDEF: void* CFDataRef
-TYPEDEF: void* CFDictionaryRef
-TYPEDEF: void* CFMutableDictionaryRef
-TYPEDEF: void* CFNumberRef
TYPEDEF: void* CFSetRef
-TYPEDEF: int CFNumberType
-: kCFNumberSInt8Type 1 ; inline
-: kCFNumberSInt16Type 2 ; inline
-: kCFNumberSInt32Type 3 ; inline
-: kCFNumberSInt64Type 4 ; inline
-: kCFNumberFloat32Type 5 ; inline
-: kCFNumberFloat64Type 6 ; inline
-: kCFNumberCharType 7 ; inline
-: kCFNumberShortType 8 ; inline
-: kCFNumberIntType 9 ; inline
-: kCFNumberLongType 10 ; inline
-: kCFNumberLongLongType 11 ; inline
-: kCFNumberFloatType 12 ; inline
-: kCFNumberDoubleType 13 ; inline
-: kCFNumberCFIndexType 14 ; inline
-: kCFNumberNSIntegerType 15 ; inline
-: kCFNumberCGFloatType 16 ; inline
-: kCFNumberMaxType 16 ; inline
-
TYPEDEF: int CFPropertyListMutabilityOptions
-: kCFPropertyListImmutable 0 ; inline
-: kCFPropertyListMutableContainers 1 ; inline
-: kCFPropertyListMutableContainersAndLeaves 2 ; inline
-
-FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
+CONSTANT: kCFPropertyListImmutable 0
+CONSTANT: kCFPropertyListMutableContainers 1
+CONSTANT: kCFPropertyListMutableContainersAndLeaves 2
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
-GENERIC: <CFNumber> ( number -- alien )
-
-M: integer <CFNumber>
- [ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
-
-M: float <CFNumber>
- [ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
-
-M: t <CFNumber>
- drop f kCFNumberIntType 1 <int> CFNumberCreate ;
-
-M: f <CFNumber>
- drop f kCFNumberIntType 0 <int> CFNumberCreate ;
-
: <CFData> ( byte-array -- alien )
- [ f ] dip dup length CFDataCreate ;
+ [ f ] dip dup length CFDataCreate ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation core-foundation.dictionaries
+arrays destructors core-foundation.strings kernel namespaces ;
+IN: core-foundation.dictionaries.tests
+
+[ ] [ { } <CFDictionary> CFRelease ] unit-test
+
+[ "raps in the back of cars and doesn't afraid of anything" ] [
+ [
+ "cpst" <CFString> &CFRelease dup "key" set
+ "raps in the back of cars and doesn't afraid of anything" <CFString> &CFRelease
+ 2array 1array <CFDictionary> &CFRelease
+ "key" get
+ CFDictionaryGetValue
+ dup [ CF>string ] when
+ ] with-destructors
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax core-foundation kernel assocs
+specialized-arrays.alien math sequences accessors ;
+IN: core-foundation.dictionaries
+
+TYPEDEF: void* CFDictionaryRef
+TYPEDEF: void* CFMutableDictionaryRef
+TYPEDEF: void* CFDictionaryKeyCallBacks*
+TYPEDEF: void* CFDictionaryValueCallBacks*
+
+FUNCTION: CFDictionaryRef CFDictionaryCreate (
+ CFAllocatorRef allocator,
+ void** keys,
+ void** values,
+ CFIndex numValues,
+ CFDictionaryKeyCallBacks* keyCallBacks,
+ CFDictionaryValueCallBacks* valueCallBacks
+) ;
+
+FUNCTION: void* CFDictionaryGetValue (
+ CFDictionaryRef theDict,
+ void* key
+) ;
+
+: <CFDictionary> ( alist -- dictionary )
+ [ kCFAllocatorDefault ] dip
+ unzip [ >void*-array ] bi@
+ [ [ underlying>> ] bi@ ] [ nip length ] 2bi
+ &: kCFTypeDictionaryKeyCallBacks
+ &: kCFTypeDictionaryValueCallBacks
+ CFDictionaryCreate ;
\ No newline at end of file
--- /dev/null
+unportable
+bindings
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation.numbers ;
+IN: core-foundation.numbers.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax kernel math core-foundation ;
+IN: core-foundation.numbers
+
+TYPEDEF: void* CFNumberRef
+
+TYPEDEF: int CFNumberType
+CONSTANT: kCFNumberSInt8Type 1
+CONSTANT: kCFNumberSInt16Type 2
+CONSTANT: kCFNumberSInt32Type 3
+CONSTANT: kCFNumberSInt64Type 4
+CONSTANT: kCFNumberFloat32Type 5
+CONSTANT: kCFNumberFloat64Type 6
+CONSTANT: kCFNumberCharType 7
+CONSTANT: kCFNumberShortType 8
+CONSTANT: kCFNumberIntType 9
+CONSTANT: kCFNumberLongType 10
+CONSTANT: kCFNumberLongLongType 11
+CONSTANT: kCFNumberFloatType 12
+CONSTANT: kCFNumberDoubleType 13
+CONSTANT: kCFNumberCFIndexType 14
+CONSTANT: kCFNumberNSIntegerType 15
+CONSTANT: kCFNumberCGFloatType 16
+CONSTANT: kCFNumberMaxType 16
+
+FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
+
+GENERIC: <CFNumber> ( number -- alien )
+
+M: integer <CFNumber>
+ [ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+
+M: float <CFNumber>
+ [ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+
+M: t <CFNumber>
+ drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+
+M: f <CFNumber>
+ drop f kCFNumberIntType 0 <int> CFNumberCreate ;
+
--- /dev/null
+unportable
[ "Hello" ] [ "Hello" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
[ "Hello\u003456" ] [ "Hello\u003456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
[ "Hello\u013456" ] [ "Hello\u013456" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
+[ ] [ "\0" <CFString> CFRelease ] unit-test
+[ "\0" ] [ "\0" <CFString> [ CF>string ] [ CFRelease ] bi ] unit-test
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.strings kernel sequences byte-arrays
-io.encodings.utf8 math core-foundation core-foundation.arrays ;
+USING: alien.syntax alien.strings io.encodings.string kernel
+sequences byte-arrays io.encodings.utf8 math core-foundation
+core-foundation.arrays destructors ;
IN: core-foundation.strings
TYPEDEF: void* CFStringRef
TYPEDEF: int CFStringEncoding
-: kCFStringEncodingMacRoman HEX: 0 ;
-: kCFStringEncodingWindowsLatin1 HEX: 0500 ;
-: kCFStringEncodingISOLatin1 HEX: 0201 ;
-: kCFStringEncodingNextStepLatin HEX: 0B01 ;
-: kCFStringEncodingASCII HEX: 0600 ;
-: kCFStringEncodingUnicode HEX: 0100 ;
-: kCFStringEncodingUTF8 HEX: 08000100 ;
-: kCFStringEncodingNonLossyASCII HEX: 0BFF ;
-: kCFStringEncodingUTF16 HEX: 0100 ;
-: kCFStringEncodingUTF16BE HEX: 10000100 ;
-: kCFStringEncodingUTF16LE HEX: 14000100 ;
-: kCFStringEncodingUTF32 HEX: 0c000100 ;
-: kCFStringEncodingUTF32BE HEX: 18000100 ;
-: kCFStringEncodingUTF32LE HEX: 1c000100 ;
+CONSTANT: kCFStringEncodingMacRoman HEX: 0
+CONSTANT: kCFStringEncodingWindowsLatin1 HEX: 0500
+CONSTANT: kCFStringEncodingISOLatin1 HEX: 0201
+CONSTANT: kCFStringEncodingNextStepLatin HEX: 0B01
+CONSTANT: kCFStringEncodingASCII HEX: 0600
+CONSTANT: kCFStringEncodingUnicode HEX: 0100
+CONSTANT: kCFStringEncodingUTF8 HEX: 08000100
+CONSTANT: kCFStringEncodingNonLossyASCII HEX: 0BFF
+CONSTANT: kCFStringEncodingUTF16 HEX: 0100
+CONSTANT: kCFStringEncodingUTF16BE HEX: 10000100
+CONSTANT: kCFStringEncodingUTF16LE HEX: 14000100
+CONSTANT: kCFStringEncodingUTF32 HEX: 0c000100
+CONSTANT: kCFStringEncodingUTF32BE HEX: 18000100
+CONSTANT: kCFStringEncodingUTF32LE HEX: 1c000100
FUNCTION: CFStringRef CFStringCreateWithBytes (
CFAllocatorRef alloc,
CFStringEncoding encoding
) ;
+FUNCTION: CFIndex CFStringGetBytes (
+ CFStringRef theString,
+ CFRange range,
+ CFStringEncoding encoding,
+ UInt8 lossByte,
+ Boolean isExternalRepresentation,
+ UInt8* buffer,
+ CFIndex maxBufLen,
+ CFIndex* usedBufLen
+) ;
+
FUNCTION: CFStringRef CFStringCreateWithCString (
CFAllocatorRef alloc,
char* cStr,
) ;
: <CFString> ( string -- alien )
- f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
- [ "CFStringCreateWithCString failed" throw ] unless* ;
+ [ f ] dip utf8 encode dup length kCFStringEncodingUTF8 f CFStringCreateWithBytes
+ [ "CFStringCreateWithBytes failed" throw ] unless* ;
: CF>string ( alien -- string )
- dup CFStringGetLength 4 * 1 + <byte-array> [
- dup length
- kCFStringEncodingUTF8
- CFStringGetCString
- [ "CFStringGetCString failed" throw ] unless
- ] keep utf8 alien>string ;
+ dup CFStringGetLength
+ [ 0 swap <CFRange> kCFStringEncodingUTF8 0 f ] keep
+ 4 * 1 + <byte-array> [ dup length 0 <CFIndex> [ CFStringGetBytes drop ] keep ] keep
+ swap *CFIndex head-slice utf8 decode ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;
: <CFStringArray> ( seq -- alien )
- [ <CFString> ] map [ <CFArray> ] [ [ CFRelease ] each ] bi ;
+ [ [ <CFString> &CFRelease ] map <CFArray> ] with-destructors ;
-Mac OS X CoreFoundation binding
+Binding to Mac OS X CoreFoundation library
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation.utilities ;
+IN: core-foundation.utilities.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math assocs kernel sequences byte-arrays strings
+hashtables alien destructors
+core-foundation.numbers core-foundation.strings
+core-foundation.arrays core-foundation.dictionaries
+core-foundation.data core-foundation ;
+IN: core-foundation.utilities
+
+GENERIC: (>cf) ( obj -- cf )
+
+M: number (>cf) <CFNumber> ;
+M: t (>cf) <CFNumber> ;
+M: f (>cf) <CFNumber> ;
+M: string (>cf) <CFString> ;
+M: byte-array (>cf) <CFData> ;
+M: hashtable (>cf) [ [ (>cf) &CFRelease ] bi@ ] assoc-map <CFDictionary> ;
+M: sequence (>cf) [ (>cf) &CFRelease ] map <CFArray> ;
+M: alien (>cf) CFRetain ;
+
+: >cf ( obj -- cf ) [ (>cf) ] with-destructors ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-graphics kernel byte-arrays ;
+IN: core-graphics.tests
+
+[ t ] [ { 100 200 } [ drop ] with-bitmap-context byte-array? ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.destructors alien.syntax
+destructors fry kernel math math.bitwise sequences libc colors
+core-graphics.types core-foundation.utilities ;
+IN: core-graphics
+
+! CGImageAlphaInfo
+C-ENUM:
+kCGImageAlphaNone
+kCGImageAlphaPremultipliedLast
+kCGImageAlphaPremultipliedFirst
+kCGImageAlphaLast
+kCGImageAlphaFirst
+kCGImageAlphaNoneSkipLast
+kCGImageAlphaNoneSkipFirst ;
+
+: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline
+: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline
+
+: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline
+: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline
+: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline
+: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline
+: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
+: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
+
+: kCGBitmapByteOrder16Host ( -- n )
+ little-endian?
+ kCGBitmapByteOrder16Little
+ kCGBitmapByteOrder16Big ? ; foldable
+
+: kCGBitmapByteOrder32Host ( -- n )
+ little-endian?
+ kCGBitmapByteOrder32Little
+ kCGBitmapByteOrder32Big ? ; foldable
+
+FUNCTION: CGColorRef CGColorCreateGenericRGB (
+ CGFloat red,
+ CGFloat green,
+ CGFloat blue,
+ CGFloat alpha
+) ;
+
+: <CGColor> ( color -- CGColor )
+ >rgba-components CGColorCreateGenericRGB ;
+
+M: color (>cf) <CGColor> ;
+
+FUNCTION: CGColorSpaceRef CGColorSpaceCreateDeviceRGB ( ) ;
+
+FUNCTION: CGContextRef CGBitmapContextCreate (
+ void* data,
+ size_t width,
+ size_t height,
+ size_t bitsPerComponent,
+ size_t bytesPerRow,
+ CGColorSpaceRef colorspace,
+ CGBitmapInfo bitmapInfo
+) ;
+
+FUNCTION: void CGColorSpaceRelease ( CGColorSpaceRef ref ) ;
+
+DESTRUCTOR: CGColorSpaceRelease
+
+FUNCTION: void CGContextRelease ( CGContextRef ref ) ;
+
+DESTRUCTOR: CGContextRelease
+
+FUNCTION: void CGContextSetRGBStrokeColor (
+ CGContextRef c,
+ CGFloat red,
+ CGFloat green,
+ CGFloat blue,
+ CGFloat alpha
+) ;
+
+FUNCTION: void CGContextSetRGBFillColor (
+ CGContextRef c,
+ CGFloat red,
+ CGFloat green,
+ CGFloat blue,
+ CGFloat alpha
+) ;
+
+FUNCTION: void CGContextSetTextPosition (
+ CGContextRef c,
+ CGFloat x,
+ CGFloat y
+) ;
+
+FUNCTION: void CGContextFillRect (
+ CGContextRef c,
+ CGRect rect
+) ;
+
+FUNCTION: void CGContextSetShouldSmoothFonts (
+ CGContextRef c,
+ bool shouldSmoothFonts
+) ;
+
+FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
+
+FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
+
+<PRIVATE
+
+: bitmap-flags ( -- flags )
+ { kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
+
+: bitmap-size ( dim -- n )
+ product "uint" heap-size * ;
+
+: malloc-bitmap-data ( dim -- alien )
+ bitmap-size malloc &free ;
+
+: bitmap-color-space ( -- color-space )
+ CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;
+
+: <CGBitmapContext> ( dim -- context )
+ [ malloc-bitmap-data ] [ first2 8 ] [ first 4 * ] tri
+ bitmap-color-space bitmap-flags CGBitmapContextCreate
+ [ "CGBitmapContextCreate failed" throw ] unless* ;
+
+: bitmap-data ( bitmap dim -- data )
+ [ CGBitmapContextGetData ] [ bitmap-size ] bi*
+ memory>byte-array ;
+
+PRIVATE>
+
+: with-bitmap-context ( dim quot -- data )
+ [
+ [ [ <CGBitmapContext> &CGContextRelease ] keep ] dip
+ [ nip call ] [ drop bitmap-data ] 3bi
+ ] with-destructors ; inline
--- /dev/null
+Binding to Mac OS X Core Graphics library
--- /dev/null
+unportable
+bindings
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: math help.markup help.syntax ;
+IN: core-graphics.types
+
+HELP: <CGRect>
+{ $values { "x" real } { "y" real } { "w" real } { "h" real } { "rect" "an " { $snippet "CGRect" } } }
+{ $description "Allocates a new " { $snippet "CGRect" } " in the Factor heap." } ;
+
+HELP: <CGPoint>
+{ $values { "x" real } { "y" real } { "point" "an " { $snippet "CGPoint" } } }
+{ $description "Allocates a new " { $snippet "CGPoint" } " in the Factor heap." } ;
+
+HELP: <CGSize>
+{ $values { "w" real } { "h" real } { "size" "an " { $snippet "CGSize" } } }
+{ $description "Allocates a new " { $snippet "CGSize" } " in the Factor heap." } ;
+
+ARTICLE: "core-graphics.types" "Core Graphics types"
+"The Core Graphics binding defines some common C structs:"
+{ $code
+ "CGRect"
+ "CGPoint"
+ "CGSize"
+}
+"Some words for working with the above:"
+{ $subsection <CGRect> }
+{ $subsection <CGPoint> }
+{ $subsection <CGSize> } ;
+
+IN: core-graphics.types
+ABOUT: "core-graphics.types"
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-graphics.types ;
+IN: core-graphics.types.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax kernel layouts ;
+IN: core-graphics.types
+
+<< cell 4 = "float" "double" ? "CGFloat" typedef >>
+
+: <CGFloat> ( x -- alien )
+ cell 4 = [ <float> ] [ <double> ] if ; inline
+
+: *CGFloat ( alien -- x )
+ cell 4 = [ *float ] [ *double ] if ; inline
+
+C-STRUCT: CGPoint
+ { "CGFloat" "x" }
+ { "CGFloat" "y" } ;
+
+: <CGPoint> ( x y -- point )
+ "CGPoint" <c-object>
+ [ set-CGPoint-y ] keep
+ [ set-CGPoint-x ] keep ;
+
+C-STRUCT: CGSize
+ { "CGFloat" "w" }
+ { "CGFloat" "h" } ;
+
+: <CGSize> ( w h -- size )
+ "CGSize" <c-object>
+ [ set-CGSize-h ] keep
+ [ set-CGSize-w ] keep ;
+
+C-STRUCT: CGRect
+ { "CGPoint" "origin" }
+ { "CGSize" "size" } ;
+
+: CGRect-x ( CGRect -- x )
+ CGRect-origin CGPoint-x ; inline
+: CGRect-y ( CGRect -- y )
+ CGRect-origin CGPoint-y ; inline
+: CGRect-w ( CGRect -- w )
+ CGRect-size CGSize-w ; inline
+: CGRect-h ( CGRect -- h )
+ CGRect-size CGSize-h ; inline
+
+: set-CGRect-x ( x CGRect -- )
+ CGRect-origin set-CGPoint-x ; inline
+: set-CGRect-y ( y CGRect -- )
+ CGRect-origin set-CGPoint-y ; inline
+: set-CGRect-w ( w CGRect -- )
+ CGRect-size set-CGSize-w ; inline
+: set-CGRect-h ( h CGRect -- )
+ CGRect-size set-CGSize-h ; inline
+
+: <CGRect> ( x y w h -- rect )
+ "CGRect" <c-object>
+ [ set-CGRect-h ] keep
+ [ set-CGRect-w ] keep
+ [ set-CGRect-y ] keep
+ [ set-CGRect-x ] keep ;
+
+: CGRect-x-y ( alien -- origin-x origin-y )
+ [ CGRect-x ] keep CGRect-y ;
+
+C-STRUCT: CGAffineTransform
+ { "CGFloat" "a" }
+ { "CGFloat" "b" }
+ { "CGFloat" "c" }
+ { "CGFloat" "d" }
+ { "CGFloat" "tx" }
+ { "CGFloat" "ty" } ;
+
+TYPEDEF: void* CGColorRef
+TYPEDEF: void* CGColorSpaceRef
+TYPEDEF: void* CGContextRef
+TYPEDEF: uint CGBitmapInfo
+
+TYPEDEF: int CGLError
+TYPEDEF: void* CGLContextObj
+TYPEDEF: int CGLContextParameter
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-text core-foundation
+core-foundation.dictionaries destructors
+arrays kernel generalizations math accessors
+core-foundation.utilities
+combinators hashtables colors ;
+IN: core-text.tests
+
+: test-font ( name -- font )
+ [ >cf &CFRelease 0.0 f CTFontCreateWithName ] with-destructors ;
+
+[ ] [ "Helvetica" test-font CFRelease ] unit-test
+
+[ ] [
+ [
+ kCTFontAttributeName "Helvetica" test-font &CFRelease 2array 1array
+ <CFDictionary> &CFRelease drop
+ ] with-destructors
+] unit-test
+
+: test-typographic-bounds ( string font -- ? )
+ [
+ test-font &CFRelease white <CTLine> &CFRelease
+ line-typographic-bounds {
+ [ width>> float? ]
+ [ ascent>> float? ]
+ [ descent>> float? ]
+ [ leading>> float? ]
+ } cleave and and and
+ ] with-destructors ;
+
+[ t ] [ "Hello world" "Helvetica" test-typographic-bounds ] unit-test
+
+[ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test
+
+[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays alien alien.c-types alien.syntax kernel
+destructors accessors fry words hashtables
+sequences memoize assocs math math.functions locals init
+namespaces combinators fonts colors core-foundation
+core-foundation.strings core-foundation.attributed-strings
+core-foundation.utilities core-graphics core-graphics.types
+core-text.fonts core-text.utilities ;
+IN: core-text
+
+TYPEDEF: void* CTLineRef
+
+C-GLOBAL: kCTFontAttributeName
+C-GLOBAL: kCTKernAttributeName
+C-GLOBAL: kCTLigatureAttributeName
+C-GLOBAL: kCTForegroundColorAttributeName
+C-GLOBAL: kCTParagraphStyleAttributeName
+C-GLOBAL: kCTUnderlineStyleAttributeName
+C-GLOBAL: kCTVerticalFormsAttributeName
+C-GLOBAL: kCTGlyphInfoAttributeName
+
+FUNCTION: CTLineRef CTLineCreateWithAttributedString ( CFAttributedStringRef string ) ;
+
+FUNCTION: void CTLineDraw ( CTLineRef line, CGContextRef context ) ;
+
+FUNCTION: CGFloat CTLineGetOffsetForStringIndex ( CTLineRef line, CFIndex charIndex, CGFloat* secondaryOffset ) ;
+
+FUNCTION: CFIndex CTLineGetStringIndexForPosition ( CTLineRef line, CGPoint position ) ;
+
+FUNCTION: double CTLineGetTypographicBounds ( CTLineRef line, CGFloat* ascent, CGFloat* descent, CGFloat* leading ) ;
+
+FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context ) ;
+
+: <CTLine> ( string open-font color -- line )
+ [
+ [
+ kCTForegroundColorAttributeName set
+ kCTFontAttributeName set
+ ] H{ } make-assoc <CFAttributedString> &CFRelease
+ CTLineCreateWithAttributedString
+ ] with-destructors ;
+
+TUPLE: line font line bounds dim bitmap age refs disposed ;
+
+TUPLE: typographic-bounds width ascent descent leading ;
+
+: line-typographic-bounds ( line -- typographic-bounds )
+ 0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
+ [ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@
+ typographic-bounds boa ;
+
+: bounds>dim ( bounds -- dim )
+ [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
+ [ ceiling >fixnum ]
+ bi@ 2array ;
+
+:: <line> ( string font -- line )
+ [
+ [let* | open-font [ font cache-font CFRetain |CFRelease ]
+ line [ string open-font font foreground>> <CTLine> |CFRelease ]
+ bounds [ line line-typographic-bounds ]
+ dim [ bounds bounds>dim ] |
+ dim [
+ {
+ [ font background>> >rgba-components CGContextSetRGBFillColor ]
+ [ 0 0 dim first2 <CGRect> CGContextFillRect ]
+ [ 0 bounds descent>> CGContextSetTextPosition ]
+ [ line swap CTLineDraw ]
+ } cleave
+ ] with-bitmap-context
+ [ open-font line bounds dim ] dip 0 0 f
+ ]
+ line boa
+ ] with-destructors ;
+
+M: line dispose* [ font>> CFRelease ] [ line>> CFRelease ] bi ;
+
+: ref/unref-line ( line n -- )
+ '[ _ + ] change-refs 0 >>age drop ;
+
+: ref-line ( line -- ) 1 ref/unref-line ;
+: unref-line ( line -- ) -1 ref/unref-line ;
+
+SYMBOL: cached-lines
+
+: cached-line ( string font -- line )
+ cached-lines get [ <line> ] 2cache ;
+
+CONSTANT: max-line-age 10
+
+: age ( obj -- ? )
+ [ 1+ ] change-age age>> max-line-age >= ;
+
+: age-line ( line -- ? )
+ #! Outputs t whether the line is dead.
+ dup refs>> 0 = [ age ] [ drop f ] if ;
+
+: age-assoc ( assoc quot -- assoc' )
+ '[ nip @ ] assoc-partition
+ [ values dispose-each ] dip ;
+
+: age-lines ( -- )
+ cached-lines global [ [ age-line ] age-assoc ] change-at ;
+
+[ H{ } clone cached-lines set-global ] "core-text" add-init-hook
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-text.fonts ;
+IN: core-text.fonts.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.syntax assocs core-foundation
+core-foundation.strings core-text.utilities destructors init
+kernel math memoize ;
+IN: core-text.fonts
+
+TYPEDEF: void* CTFontRef
+TYPEDEF: void* CTFontDescriptorRef
+
+! CTFontSymbolicTraits
+: kCTFontItalicTrait ( -- n ) 0 2^ ; inline
+: kCTFontBoldTrait ( -- n ) 1 2^ ; inline
+: kCTFontExpandedTrait ( -- n ) 5 2^ ; inline
+: kCTFontCondensedTrait ( -- n ) 6 2^ ; inline
+: kCTFontMonoSpaceTrait ( -- n ) 10 2^ ; inline
+: kCTFontVerticalTrait ( -- n ) 11 2^ ; inline
+: kCTFontUIOptimizedTrait ( -- n ) 12 2^ ; inline
+
+C-GLOBAL: kCTFontSymbolicTrait
+C-GLOBAL: kCTFontWeightTrait
+C-GLOBAL: kCTFontWidthTrait
+C-GLOBAL: kCTFontSlantTrait
+
+C-GLOBAL: kCTFontNameAttribute
+C-GLOBAL: kCTFontDisplayNameAttribute
+C-GLOBAL: kCTFontFamilyNameAttribute
+C-GLOBAL: kCTFontStyleNameAttribute
+C-GLOBAL: kCTFontTraitsAttribute
+C-GLOBAL: kCTFontVariationAttribute
+C-GLOBAL: kCTFontSizeAttribute
+C-GLOBAL: kCTFontMatrixAttribute
+C-GLOBAL: kCTFontCascadeListAttribute
+C-GLOBAL: kCTFontCharacterSetAttribute
+C-GLOBAL: kCTFontLanguagesAttribute
+C-GLOBAL: kCTFontBaselineAdjustAttribute
+C-GLOBAL: kCTFontMacintoshEncodingsAttribute
+C-GLOBAL: kCTFontFeaturesAttribute
+C-GLOBAL: kCTFontFeatureSettingsAttribute
+C-GLOBAL: kCTFontFixedAdvanceAttribute
+C-GLOBAL: kCTFontOrientationAttribute
+
+FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes (
+ CFDictionaryRef attributes
+) ;
+
+FUNCTION: CTFontRef CTFontCreateWithName (
+ CFStringRef name,
+ CGFloat size,
+ CGAffineTransform* matrix
+) ;
+
+FUNCTION: CTFontRef CTFontCreateWithFontDescriptor (
+ CTFontDescriptorRef descriptor,
+ CGFloat size,
+ CGAffineTransform* matrix
+) ;
+
+FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
+ CTFontRef font,
+ CGFloat size,
+ CGAffineTransform* matrix,
+ uint32_t symTraitValue,
+ uint32_t symTraitMask
+) ;
+
+CONSTANT: font-names
+ H{
+ { "monospace" "Monaco" }
+ { "sans-serif" "Lucida Grande" }
+ { "serif" "Times" }
+ }
+
+: font-name ( string -- string' )
+ font-names at-default ;
+
+: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
+
+: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
+
+: font-traits ( font -- n )
+ [ 0 ] dip
+ [ bold?>> [ (bold) ] when ]
+ [ italic?>> [ (italic) ] when ] bi ;
+
+: apply-font-traits ( font style -- font' )
+ [ drop ] [ [ 0.0 f ] dip font-traits dup ] 2bi
+ CTFontCreateCopyWithSymbolicTraits
+ dup [ [ CFRelease ] dip ] [ drop ] if ;
+
+MEMO: (cache-font) ( font -- open-font )
+ [
+ [
+ [ name>> font-name <CFString> &CFRelease ] [ size>> ] bi
+ f CTFontCreateWithName
+ ] keep apply-font-traits
+ ] with-destructors ;
+
+: cache-font ( font -- open-font )
+ clone f >>foreground f >>background (cache-font) ;
+
+[ \ (cache-font) reset-memoized ] "core-text.fonts" add-init-hook
--- /dev/null
+Binding for Mac OS X Core Text library
--- /dev/null
+unportable
+bindings
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-text.utilities ;
+IN: core-text.utilities.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words parser alien alien.c-types kernel fry accessors ;
+IN: core-text.utilities
+
+: C-GLOBAL:
+ CREATE-WORD
+ dup name>> '[ _ f dlsym *void* ]
+ (( -- value )) define-declared ; parsing
[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
-[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
GENERIC: one
M: integer one ;
! Copyright (C) 2007, 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors parser generic kernel classes classes.tuple
-words slots assocs sequences arrays vectors definitions
-math hashtables sets generalizations namespaces make
-words.symbol ;
+USING: accessors arrays assocs classes.tuple definitions
+generalizations generic hashtables kernel lexer make math parser
+sequences sets slots words words.symbol fry ;
IN: delegate
: protocol-words ( protocol -- words )
define ;
: change-word-prop ( word prop quot -- )
- rot props>> swap change-at ; inline
+ [ swap props>> ] dip change-at ; inline
: register-protocol ( group class quot -- )
- rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
+ [ \ protocol-consult ] 2dip
+ '[ [ _ _ swap ] dip ?set-at ] change-word-prop ;
: define-consult ( group class quot -- )
[ register-protocol ]
- [ [ group-words ] 2dip [ consult-method ] 2curry each ]
+ [ [ group-words ] 2dip '[ _ _ consult-method ] each ]
3bi ;
: CONSULT:
[ dup word? [ 0 2array ] when ] map ;
: define-protocol ( protocol wordlist -- )
- fill-in-depth
- [ forget-old-definitions ]
- [ add-new-definitions ]
- [ initialize-protocol-props ] 2tri ;
+ [ drop define-symbol ] [
+ fill-in-depth
+ [ forget-old-definitions ]
+ [ add-new-definitions ]
+ [ initialize-protocol-props ] 2tri
+ ] 2bi ;
: PROTOCOL:
- CREATE-WORD
- [ define-symbol ]
- [ f "inline" set-word-prop ]
- [ parse-definition define-protocol ] tri ; parsing
+ CREATE-WORD parse-definition define-protocol ; parsing
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol definer drop \ PROTOCOL: \ ; ;
M: protocol group-words protocol-words ;
+
+: SLOT-PROTOCOL:
+ CREATE-WORD ";" parse-tokens
+ [ [ reader-word ] [ writer-word ] bi 2array ] map concat
+ define-protocol ; parsing
\ No newline at end of file
{ $description "Removes all text from the document." }
{ $side-effects "document" } ;
-HELP: prev-elt
-{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
-{ $contract "Outputs the location of the first occurrence of the element prior to " { $snippet "loc" } "." } ;
-
-{ prev-elt next-elt } related-words
-
-HELP: next-elt
-{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
-{ $contract "Outputs the location of the first occurrence of the element following " { $snippet "loc" } "." } ;
-
-HELP: char-elt
-{ $class-description "An element representing a single character." } ;
-
-HELP: one-word-elt
-{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the word at the current location." } ;
-
-{ one-word-elt word-elt } related-words
-
-HELP: word-elt
-{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next word from the current location." } ;
-
-HELP: one-line-elt
-{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the line at the current location." } ;
-
-{ one-line-elt line-elt } related-words
-
-HELP: line-elt
-{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next line from the current location." } ;
-
-HELP: doc-elt
-{ $class-description "An element representing the entire document. The " { $link prev-elt } " word outputs the start of the document and the " { $link next-elt } " word outputs the end of the document." } ;
-
ARTICLE: "documents" "Documents"
+"The " { $vocab-link "documents" } " vocabulary implements " { $emphasis "documents" } ", which are models storing a passage of text as a sequence of lines. Operations are defined for operating on subranges of the text, and " { $link "gadgets-editors" } " can display these models."
{ $subsection document }
{ $subsection <document> }
"Getting and setting the contents of the entire document:"
{ $subsection remove-doc-range }
"A combinator:"
{ $subsection each-line }
+{ $subsection "document-locs" }
+{ $subsection "documents.elements" }
{ $see-also "gadgets-editors" } ;
-ARTICLE: "document-locs-elts" "Locations and elements"
+ARTICLE: "document-locs" "Document locations"
"Locations in the document are represented as a line/column number pair, with both indices being zero-based. There are some words for manipulating locations:"
{ $subsection +col }
{ $subsection +line }
{ $subsection =col }
{ $subsection =line }
-"New locations can be created out of existing ones by finding the start or end of a document element nearest to a given location."
-{ $subsection prev-elt }
-{ $subsection next-elt }
-"The different types of document elements correspond to the standard editing taxonomy:"
-{ $subsection char-elt }
-{ $subsection one-word-elt }
-{ $subsection word-elt }
-{ $subsection one-line-elt }
-{ $subsection line-elt }
-{ $subsection doc-elt }
"Miscellaneous words for working with locations:"
{ $subsection lines-equal? }
{ $subsection validate-loc } ;
+
+ABOUT: "documents"
IN: documents.tests
-USING: documents namespaces tools.test make arrays kernel fry ;
+USING: documents documents.private accessors sequences
+namespaces tools.test make arrays kernel fry ;
! Tests
"doc" get doc-string
] unit-test
-<document> "doc" set
-"Hello world" "doc" get set-doc-string
-[ { 0 0 } ] [ { 0 0 } "doc" get T{ one-word-elt } prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get T{ one-word-elt } prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get T{ one-word-elt } prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 2 } "doc" get T{ one-word-elt } next-elt ] unit-test
-[ { 0 5 } ] [ { 0 5 } "doc" get T{ one-word-elt } next-elt ] unit-test
+! Undo/redo
+[ ] [ <document> "d" set ] unit-test
-<document> "doc" set
-"Hello\nworld, how are\nyou?" "doc" get set-doc-string
+[ ] [ "Hello, world." "d" get set-doc-string ] unit-test
-[ { 2 4 } ] [ "doc" get doc-end ] unit-test
+[
+ T{ edit
+ { old-string "" }
+ { new-string "Hello, world." }
+ { from { 0 0 } }
+ { old-to { 0 0 } }
+ { new-to { 0 13 } }
+ }
+] [ "d" get undos>> first ] unit-test
-[ { 0 0 } ] [ { 0 3 } "doc" get T{ line-elt } prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 3 } "doc" get T{ line-elt } prev-elt ] unit-test
-[ { 2 4 } ] [ { 2 1 } "doc" get T{ line-elt } next-elt ] unit-test
+[ ] [ "Goodbye" { 0 0 } { 0 5 } "d" get set-doc-range ] unit-test
+
+[ "Goodbye, world." ] [ "d" get doc-string ] unit-test
+
+[ ] [ "cruel " { 0 9 } { 0 9 } "d" get set-doc-range ] unit-test
+
+[ 3 ] [ "d" get undos>> length ] unit-test
+
+[ "Goodbye, cruel world." ] [ "d" get doc-string ] unit-test
+
+[ "" { 0 9 } { 0 15 } ] [
+ "d" get undos>> peek
+ [ old-string>> ] [ from>> ] [ new-to>> ] tri
+] unit-test
+
+[ ] [ "d" get undo ] unit-test
+
+[ "Goodbye, world." ] [ "d" get doc-string ] unit-test
+
+[ ] [ "d" get undo ] unit-test
+
+[ "Hello, world." ] [ "d" get doc-string ] unit-test
+
+[ ] [ "d" get redo ] unit-test
+
+[ "Goodbye, world." ] [ "d" get doc-string ] unit-test
+
+[ ] [ <document> "d" set ] unit-test
+
+[ ] [ "d" get clear-doc ] unit-test
+
+[ ] [ "d" get clear-doc ] unit-test
+
+[ 0 ] [ "d" get undos>> length ] unit-test
+
+[ ] [ <document> "d" set ] unit-test
+
+[ ] [ "d" get value>> "value" set ] unit-test
+
+[ ] [ "Hello world" "d" get set-doc-string ] unit-test
+
+[ { "" } ] [ "value" get ] unit-test
\ No newline at end of file
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io kernel math models namespaces make
sequences strings splitting combinators unicode.categories
-math.order math.ranges ;
+math.order math.ranges fry locals ;
IN: documents
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
-TUPLE: document < model locs ;
+TUPLE: edit old-string new-string from old-to new-to ;
+
+C: <edit> edit
+
+TUPLE: document < model locs undos redos inside-undo? ;
+
+: clear-undo ( document -- )
+ V{ } clone >>undos
+ V{ } clone >>redos
+ drop ;
: <document> ( -- document )
- V{ "" } clone document new-model
- V{ } clone >>locs ;
+ { "" } document new-model
+ V{ } clone >>locs
+ dup clear-undo ;
: add-loc ( loc document -- ) locs>> push ;
: doc-line ( n document -- string ) value>> nth ;
+: line-end ( line# document -- loc )
+ [ drop ] [ doc-line length ] 2bi 2array ;
+
: doc-lines ( from to document -- slice )
- [ 1+ ] dip value>> <slice> ;
+ [ 1+ ] [ value>> ] bi* <slice> ;
: start-on-line ( document from line# -- n1 )
[ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
[ [ document get ] 2dip end-on-line ]
2bi* ;
+: last-line# ( document -- line )
+ value>> length 1- ;
+
+CONSTANT: doc-start { 0 0 }
+
+: doc-end ( document -- loc )
+ [ last-line# ] keep line-end ;
+
+<PRIVATE
+
: (doc-range) ( from to line# -- )
[ start/end-on-line ] keep document get doc-line <slice> , ;
-: doc-range ( from to document -- string )
- [
- document set 2dup [
- [ 2dup ] dip (doc-range)
- ] each-line 2drop
- ] { } make "\n" join ;
-
: text+loc ( lines loc -- loc )
over [
over length 1 = [
: loc-col/str ( loc document -- str col )
[ first2 swap ] dip nth swap ;
-: prepare-insert ( newinput from to lines -- newinput )
+: prepare-insert ( new-lines from to lines -- new-lines )
tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
pick append-last over prepend-first ;
-: (set-doc-range) ( newlines from to lines -- )
+: (set-doc-range) ( doc-lines from to lines -- changed-lines )
[ prepare-insert ] 3keep
[ [ first ] bi@ 1+ ] dip
replace-slice ;
-: set-doc-range ( string from to document -- )
+: entire-doc ( document -- start end document )
+ [ [ doc-start ] dip doc-end ] keep ;
+
+: with-undo ( document quot: ( document -- ) -- )
+ [ t >>inside-undo? ] dip keep f >>inside-undo? drop ; inline
+
+PRIVATE>
+
+: doc-range ( from to document -- string )
[
- [ [ string-lines ] dip [ text+loc ] 2keep ] 2dip
- [ [ (set-doc-range) ] keep ] change-model
- ] keep update-locs ;
+ document set 2dup [
+ [ 2dup ] dip (doc-range)
+ ] each-line 2drop
+ ] { } make "\n" join ;
+
+: add-undo ( edit document -- )
+ dup inside-undo?>> [ 2drop ] [
+ [ undos>> push ] keep
+ redos>> delete-all
+ ] if ;
+
+:: set-doc-range ( string from to document -- )
+ from to = string empty? and [
+ string string-lines :> new-lines
+ new-lines from text+loc :> new-to
+ from to document doc-range :> old-string
+ old-string string from to new-to <edit> document add-undo
+ new-lines from to document [ (set-doc-range) ] change-model
+ new-to document update-locs
+ ] unless ;
+
+: change-doc-range ( from to document quot -- )
+ '[ doc-range @ ] 3keep set-doc-range ; inline
: remove-doc-range ( from to document -- )
[ "" ] 3dip set-doc-range ;
-: last-line# ( document -- line )
- value>> length 1- ;
-
: validate-line ( line document -- line )
last-line# min 0 max ;
: validate-col ( col line document -- col )
doc-line length min 0 max ;
-: line-end ( line# document -- loc )
- dupd doc-line length 2array ;
-
: line-end? ( loc document -- ? )
[ first2 swap ] dip doc-line length = ;
-: doc-end ( document -- loc )
- [ last-line# ] keep line-end ;
-
: validate-loc ( loc document -- newloc )
- over first over value>> length >= [
+ 2dup [ first ] [ value>> length ] bi* >= [
nip doc-end
] [
over first 0 < [
] if ;
: doc-string ( document -- str )
- value>> "\n" join ;
+ entire-doc doc-range ;
: set-doc-string ( string document -- )
- [ string-lines V{ } like ] dip [ set-model ] keep
- [ doc-end ] [ update-locs ] bi ;
+ entire-doc set-doc-range ;
: clear-doc ( document -- )
- "" swap set-doc-string ;
-
-GENERIC: prev-elt ( loc document elt -- newloc )
-GENERIC: next-elt ( loc document elt -- newloc )
-
-: prev/next-elt ( loc document elt -- start end )
- [ prev-elt ] [ next-elt ] 3bi ;
-
-: elt-string ( loc document elt -- string )
- [ prev/next-elt ] [ drop ] 2bi doc-range ;
-
-TUPLE: char-elt ;
-
-: (prev-char) ( loc document quot -- loc )
- {
- { [ pick { 0 0 } = ] [ 2drop ] }
- { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
- [ call ]
- } cond ; inline
-
-: (next-char) ( loc document quot -- loc )
- {
- { [ 2over doc-end = ] [ 2drop ] }
- { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
- [ call ]
- } cond ; inline
-
-M: char-elt prev-elt
- drop [ drop -1 +col ] (prev-char) ;
-
-M: char-elt next-elt
- drop [ drop 1 +col ] (next-char) ;
-
-TUPLE: one-char-elt ;
-
-M: one-char-elt prev-elt 2drop ;
-
-M: one-char-elt next-elt 2drop ;
-
-: (word-elt) ( loc document quot -- loc )
- pick [
- [ [ first2 swap ] dip doc-line ] dip call
- ] dip =col ; inline
-
-: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
-
-: break-detector ( ? -- quot )
- [ [ blank? ] dip xor ] curry ; inline
-
-: (prev-word) ( ? col str -- col )
- rot break-detector find-last-from drop ?1+ ;
-
-: (next-word) ( ? col str -- col )
- [ rot break-detector find-from drop ] keep
- over not [ nip length ] [ drop ] if ;
-
-TUPLE: one-word-elt ;
-
-M: one-word-elt prev-elt
- drop
- [ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
-
-M: one-word-elt next-elt
- drop
- [ [ f ] 2dip (next-word) ] (word-elt) ;
-
-TUPLE: word-elt ;
-
-M: word-elt prev-elt
- drop
- [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
- (prev-char) ;
-
-M: word-elt next-elt
- drop
- [ [ ((word-elt)) (next-word) ] (word-elt) ]
- (next-char) ;
-
-TUPLE: one-line-elt ;
+ [ "" ] dip set-doc-string ;
-M: one-line-elt prev-elt
- 2drop first 0 2array ;
+<PRIVATE
-M: one-line-elt next-elt
- drop [ first dup ] dip doc-line length 2array ;
+: undo/redo-edit ( edit document string-quot to-quot -- )
+ '[ [ _ [ from>> ] _ tri ] dip set-doc-range ] with-undo ; inline
-TUPLE: line-elt ;
+: undo-edit ( edit document -- )
+ [ old-string>> ] [ new-to>> ] undo/redo-edit ;
-M: line-elt prev-elt
- 2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
+: redo-edit ( edit document -- )
+ [ new-string>> ] [ old-to>> ] undo/redo-edit ;
-M: line-elt next-elt
- drop over first over last-line# number=
- [ nip doc-end ] [ drop 1 +line ] if ;
+: undo/redo ( document source-quot dest-quot do-quot -- )
+ [ dupd call [ drop ] ] 2dip
+ '[ pop swap [ @ push ] _ 2bi ] if-empty ; inline
-TUPLE: doc-elt ;
+PRIVATE>
-M: doc-elt prev-elt 3drop { 0 0 } ;
+: undo ( document -- )
+ [ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ;
-M: doc-elt next-elt drop nip doc-end ;
+: redo ( document -- )
+ [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax documents ;
+IN: documents.elements
+
+HELP: prev-elt
+{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
+{ $contract "Outputs the location of the first occurrence of the element prior to " { $snippet "loc" } "." } ;
+
+{ prev-elt next-elt } related-words
+
+HELP: next-elt
+{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
+{ $contract "Outputs the location of the first occurrence of the element following " { $snippet "loc" } "." } ;
+
+HELP: char-elt
+{ $class-description "An element representing a single character." } ;
+
+HELP: one-word-elt
+{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the word at the current location." } ;
+
+{ one-word-elt word-elt } related-words
+
+HELP: word-elt
+{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next word from the current location." } ;
+
+HELP: one-line-elt
+{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the line at the current location." } ;
+
+{ one-line-elt line-elt } related-words
+
+HELP: line-elt
+{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next line from the current location." } ;
+
+HELP: doc-elt
+{ $class-description "An element representing the entire document. The " { $link prev-elt } " word outputs the start of the document and the " { $link next-elt } " word outputs the end of the document." } ;
+
+ARTICLE: "documents.elements" "Document elements"
+"Document elements, defined in the " { $vocab-link "documents.elements" } " vocabulary, overlay a hierarchy of structure on top of the flat sequence of characters presented by the document."
+$nl
+"The different types of document elements correspond to the standard editing taxonomy:"
+{ $subsection char-elt }
+{ $subsection one-word-elt }
+{ $subsection word-elt }
+{ $subsection one-line-elt }
+{ $subsection line-elt }
+{ $subsection doc-elt }
+"New locations can be created out of existing ones by finding the start or end of a document element nearest to a given location."
+{ $subsection prev-elt }
+{ $subsection next-elt } ;
+
+ABOUT: "documents.elements"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test namespaces documents documents.elements ;
+IN: document.elements.tests
+
+<document> "doc" set
+"Hello world" "doc" get set-doc-string
+[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
+[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
+
+<document> "doc" set
+"Hello\nworld, how are\nyou?" "doc" get set-doc-string
+
+[ { 2 4 } ] [ "doc" get doc-end ] unit-test
+
+[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
+[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators documents fry kernel math sequences
+unicode.categories ;
+IN: documents.elements
+
+GENERIC: prev-elt ( loc document elt -- newloc )
+GENERIC: next-elt ( loc document elt -- newloc )
+
+: prev/next-elt ( loc document elt -- start end )
+ [ prev-elt ] [ next-elt ] 3bi ;
+
+: elt-string ( loc document elt -- string )
+ [ prev/next-elt ] [ drop ] 2bi doc-range ;
+
+: set-elt-string ( string loc document elt -- )
+ [ prev/next-elt ] [ drop ] 2bi set-doc-range ;
+
+SINGLETON: char-elt
+
+<PRIVATE
+
+: (prev-char) ( loc document quot -- loc )
+ {
+ { [ pick { 0 0 } = ] [ 2drop ] }
+ { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
+ [ call ]
+ } cond ; inline
+
+: (next-char) ( loc document quot -- loc )
+ {
+ { [ 2over doc-end = ] [ 2drop ] }
+ { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
+ [ call ]
+ } cond ; inline
+
+PRIVATE>
+
+M: char-elt prev-elt
+ drop [ drop -1 +col ] (prev-char) ;
+
+M: char-elt next-elt
+ drop [ drop 1 +col ] (next-char) ;
+
+SINGLETON: one-char-elt
+
+M: one-char-elt prev-elt 2drop ;
+
+M: one-char-elt next-elt 2drop ;
+
+<PRIVATE
+
+: (word-elt) ( loc document quot -- loc )
+ pick [
+ [ [ first2 swap ] dip doc-line ] dip call
+ ] dip =col ; inline
+
+: ((word-elt)) ( n seq -- ? n seq )
+ [ ?nth blank? ] 2keep ;
+
+: break-detector ( ? -- quot )
+ '[ blank? _ xor ] ; inline
+
+: (prev-word) ( ? col str -- col )
+ rot break-detector find-last-from drop ?1+ ;
+
+: (next-word) ( ? col str -- col )
+ [ rot break-detector find-from drop ] keep
+ over not [ nip length ] [ drop ] if ;
+
+PRIVATE>
+
+SINGLETON: one-word-elt
+
+M: one-word-elt prev-elt
+ drop
+ [ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
+
+M: one-word-elt next-elt
+ drop
+ [ [ f ] 2dip (next-word) ] (word-elt) ;
+
+SINGLETON: word-elt
+
+M: word-elt prev-elt
+ drop
+ [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
+ (prev-char) ;
+
+M: word-elt next-elt
+ drop
+ [ [ ((word-elt)) (next-word) ] (word-elt) ]
+ (next-char) ;
+
+SINGLETON: one-line-elt
+
+M: one-line-elt prev-elt
+ 2drop first 0 2array ;
+
+M: one-line-elt next-elt
+ drop [ first dup ] dip doc-line length 2array ;
+
+SINGLETON: line-elt
+
+M: line-elt prev-elt
+ 2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
+
+M: line-elt next-elt
+ drop over first over last-line# number=
+ [ nip doc-end ] [ drop 1 +line ] if ;
+
+SINGLETON: doc-elt
+
+M: doc-elt prev-elt 3drop { 0 0 } ;
+
+M: doc-elt next-elt drop nip doc-end ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel colors ;
+IN: fonts
+
+HELP: <font>
+{ $values { "font" font } }
+{ $description "Creates a new font." } ;
+
+HELP: font
+{ $class-description "The class of fonts." } ;
+
+HELP: font-with-background
+{ $values
+ { "font" font } { "color" color }
+ { "font'" font }
+}
+{ $description "Creates a new font equal to the given font, except with a different " { $slot "background" } " slot." } ;
+
+HELP: font-with-foreground
+{ $values
+ { "font" font } { "color" color }
+ { "font'" font }
+}
+{ $description "Creates a new font equal to the given font, except with a different " { $slot "foreground" } " slot." } ;
+
+ARTICLE: "fonts" "Fonts"
+"The " { $vocab-link "fonts" } " vocabulary implements a data type for fonts that other vocabularies, for example " { $link "ui" } ", can use. A font combines a font name, size, style, and color information into a single object."
+{ $subsection font }
+{ $subsection <font> }
+"Modifying fonts:"
+{ $subsection font-with-foreground }
+{ $subsection font-with-background }
+"Useful constants:"
+{ $subsection monospace-font }
+{ $subsection sans-serif-font }
+{ $subsection serif-font } ;
+
+ABOUT: "fonts"
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test fonts ;
+IN: fonts.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel colors accessors combinators ;
+IN: fonts
+
+TUPLE: font name size bold? italic? foreground background ;
+
+: <font> ( -- font )
+ font new
+ black >>foreground
+ white >>background ; inline
+
+: font-with-foreground ( font color -- font' )
+ [ clone ] dip >>foreground ; inline
+
+: font-with-background ( font color -- font' )
+ [ clone ] dip >>background ; inline
+
+: reverse-video-font ( font -- font )
+ clone dup
+ [ foreground>> ] [ background>> ] bi
+ [ >>background ] [ >>foreground ] bi* ;
+
+: derive-font ( base font -- font' )
+ [ clone ] dip over {
+ [ [ name>> ] either? >>name ]
+ [ [ size>> ] either? >>size ]
+ [ [ bold?>> ] either? >>bold? ]
+ [ [ italic?>> ] either? >>italic? ]
+ [ [ foreground>> ] either? >>foreground ]
+ [ [ background>> ] either? >>background ]
+ } 2cleave ;
+
+: serif-font ( -- font )
+ <font>
+ "serif" >>name
+ 12 >>size ; foldable
+
+: sans-serif-font ( -- font )
+ <font>
+ "sans-serif" >>name
+ 12 >>size ; foldable
+
+: monospace-font ( -- font )
+ <font>
+ "monospace" >>name
+ 12 >>size ; foldable
\ No newline at end of file
IN: freetype
<< "freetype" {
- { [ os macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
+ { [ os macosx? ] [ "/usr/X11R6/lib/libfreetype.6.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "freetype6.dll" "cdecl" add-library ] }
{ [ t ] [ drop ] }
} cond >>
{ "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The " { $link POSTPONE: QUALIFIED: } " word implements qualified naming, which can be used to resolve ambiguities." }
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
- { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by ``multiple inheritance'' in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
+ { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
{ "Performance-sensitive code should have a static stack effect so that it can be compiled by the optimizing word compiler, which generates more efficient code than the non-optimizing quotation compiler. See " { $link "inference" } " and " { $link "compiler" } "."
$nl
"This means that methods defined on performance sensitive, frequently-called core generic words such as " { $link nth } " should have static stack effects which are consistent with each other, since a generic word will only have a static stack effect if all methods do."
[ t ] [
"foo" article-children
- "foo" "help.crossref.tests" lookup 1array sequence=
+ "foo" "help.crossref.tests" lookup >link 1array sequence=
] unit-test
[ "foo" ] [ "foo" "help.crossref.tests" lookup article-parent ] unit-test
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic assocs
+USING: arrays definitions generic assocs math fry
io kernel namespaces prettyprint prettyprint.sections
sequences words summary classes help.topics help.markup ;
IN: help.crossref
+: article-links ( topic elements -- seq )
+ [ article-content ] dip
+ collect-elements [ >link ] map ;
+
: article-children ( topic -- seq )
- article-content { $subsection } collect-elements ;
+ { $subsection } article-links ;
M: link uses
- article-content
- { $subsection $link $see-also }
- collect-elements [ \ f or ] map ;
+ { $subsection $link $see-also } article-links ;
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
: unxref-article ( topic -- )
>link unxref ;
+
+: prev/next ( obj seq n -- obj' )
+ [ [ index dup ] keep ] dip swap
+ '[ _ + _ ?nth ] when ;
+
+: prev/next-article ( article n -- article' )
+ [ dup article-parent dup ] dip
+ '[ article-children _ prev/next ] [ 2drop f ] if ;
+
+: prev-article ( article -- prev ) -1 prev/next-article ;
+
+: next-article ( article -- next ) 1 prev/next-article ;
\ No newline at end of file
HELP: $instance
{ $values { "element" "an array with shape " { $snippet "{ class }" } } }
{ $description
- "Produces the text ``a " { $emphasis "class" } "'' or ``an " { $emphasis "class" } "'', depending on the first letter of " { $emphasis "class" } "."
+ "Produces the text “a " { $emphasis "class" } "” or “an " { $emphasis "class" } "”, depending on the first letter of " { $emphasis "class" } "."
}
{ $examples
{ $markup-example { $instance string } }
HELP: $maybe
{ $values { "element" "an array with shape " { $snippet "{ class }" } } }
{ $description
- "Produces the text ``a " { $emphasis "class" } " or f'' or ``an " { $emphasis "class" } " or f'', depending on the first letter of " { $emphasis "class" } "."
+ "Produces the text “a " { $emphasis "class" } " or f” or “an " { $emphasis "class" } " or f”, depending on the first letter of " { $emphasis "class" } "."
}
{ $examples
{ $markup-example { $maybe string } }
HELP: $quotation
{ $values { "element" "an array with shape " { $snippet "{ effect }" } } }
{ $description
- "Produces the text ``a quotation with stack effect " { $emphasis "effect" } "''."
+ "Produces the text “a quotation with stack effect " { $emphasis "effect" } "”."
}
{ $examples
{ $markup-example { $quotation "( obj -- )" } }
M: word set-article-parent swap "help-parent" set-word-prop ;
-: $doc-path ( article -- )
- help-path [
- [
- help-path-style get [
- "Parent topics: " write $links
- ] with-style
- ] ($block)
- ] unless-empty ;
+: ($title) ( topic -- )
+ [ [ article-title ] [ >link ] bi write-object ] ($block) ;
+
+: $navigation-row ( content element label -- )
+ [ prefix 1array ] dip prefix , ;
+
+: $navigation-table ( topic -- )
+ [
+ [ help-path [ \ $links "Up:" $navigation-row ] unless-empty ]
+ [ prev-article [ 1array \ $long-link "Prev:" $navigation-row ] when* ]
+ [ next-article [ 1array \ $long-link "Next:" $navigation-row ] when* ]
+ tri
+ ] { } make [ $table ] unless-empty ;
: $title ( topic -- )
title-style get [
title-style get [
- dup [
- dup article-title swap >link write-object
- ] ($block) $doc-path
+ [ ($title) ]
+ [ help-path-style get [ $navigation-table ] with-style ] bi
] with-nesting
] with-style nl ;
: print-topic ( topic -- )
>link
- last-element off dup $title
- article-content print-content nl ;
+ last-element off
+ [ $title ] [ article-content print-content nl ] bi ;
SYMBOL: help-hook
: about ( vocab -- )
dup require
- dup vocab [ ] [
- "No such vocabulary: " prepend throw
- ] ?if
- dup vocab-help [
- help
- ] [
+ dup vocab [ ] [ no-vocab ] ?if
+ dup vocab-help [ help ] [
"The " write vocab-name write
" vocabulary does not define a main help article." print
"To define one, refer to \\ ABOUT: help" print
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces make parser prettyprint sequences strings
-io.styles vectors words math sorting splitting classes slots
-vocabs help.stylesheet help.topics vocabs.loader quotations
+io.styles vectors words math sorting splitting classes slots fry
+sets vocabs help.stylesheet help.topics vocabs.loader quotations
combinators ;
IN: help.markup
: ($long-link) ( object -- )
[ article-title ] [ >link ] bi write-link ;
+: $long-link ( object -- )
+ first ($long-link) ;
+
: ($subsection) ( element quot -- )
[
subsection-style get [
"See also" $heading $links ;
: related-words ( seq -- )
- dup [ "related" set-word-prop ] curry each ;
+ dup '[ _ "related" set-word-prop ] each ;
: $related ( element -- )
first dup "related" word-prop remove
GENERIC: elements* ( elt-type element -- )
-M: simple-element elements* [ elements* ] with each ;
+M: simple-element elements*
+ [ elements* ] with each ;
M: object elements* 2drop ;
: elements ( elt-type element -- seq ) [ elements* ] { } make ;
: collect-elements ( element seq -- elements )
- [
- swap [
- elements [
- rest [ dup set ] each
- ] each
- ] curry each
- ] H{ } make-assoc keys ;
+ swap '[ _ elements [ rest ] map concat ] map concat prune ;
: <$link> ( topic -- element )
- \ $link swap 2array ;
+ 1array \ $link prefix ;
+
+: <$snippet> ( str -- element )
+ 1array \ $snippet prefix ;
-! Copyright (C) 2005, 2006 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.styles namespaces colors ;
IN: help.stylesheet
SYMBOL: default-span-style
H{
- { font "sans-serif" }
+ { font-name "sans-serif" }
{ font-size 12 }
{ font-style plain }
} default-span-style set-global
SYMBOL: title-style
H{
- { font "sans-serif" }
+ { font-name "sans-serif" }
{ font-size 18 }
{ font-style bold }
{ wrap-margin 500 }
SYMBOL: heading-style
H{
- { font "sans-serif" }
+ { font-name "sans-serif" }
{ font-size 16 }
{ font-style bold }
} heading-style set-global
SYMBOL: subsection-style
H{
- { font "sans-serif" }
+ { font-name "sans-serif" }
{ font-size 14 }
{ font-style bold }
} subsection-style set-global
SYMBOL: snippet-style
H{
- { font "monospace" }
+ { font-name "monospace" }
{ font-size 12 }
{ foreground T{ rgba f 0.1 0.1 0.4 1 } }
} snippet-style set-global
SYMBOL: url-style
H{
- { font "monospace" }
+ { font-name "monospace" }
{ foreground T{ rgba f 0.0 0.0 1.0 1.0 } }
} url-style set-global
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.x
USING: accessors arrays definitions generic assocs
io kernel namespaces make prettyprint prettyprint.sections
M: link >link ;
M: vocab-spec >link ;
M: object >link link boa ;
+M: f >link drop \ f >link ;
PREDICATE: word-link < link name>> word? ;
M: link summary
[
"Link: " %
- name>> dup word? [ summary ] [ unparse ] if %
+ name>> dup word? [ summary ] [ unparse-short ] if %
] "" make ;
! Help articles
M: f article-title drop \ f article-title ;
M: f article-content drop \ f article-content ;
M: f article-parent drop \ f article-parent ;
-M: f set-article-parent drop \ f set-article-parent ;
+M: f set-article-parent drop \ f set-article-parent ;
\ No newline at end of file
USING: help.markup help.syntax ui.commands ui.operations
-ui.tools.search ui.tools.workspace editors vocabs.loader
-kernel sequences prettyprint tools.test tools.vocabs strings
-unicode.categories unicode.case ui.tools.browser ;
+editors vocabs.loader kernel sequences prettyprint tools.test
+tools.vocabs strings unicode.categories unicode.case
+ui.tools.browser ui.tools.common ;
IN: help.tutorial
ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
{ $code "USE: tools.scaffold" }
"Then, ask the scaffold tool to create a new vocabulary named " { $snippet "palindrome" } ":"
{ $code "\"resource:work\" \"palindrome\" scaffold-vocab" }
-"If you look at the output, you will see that a few files were created in your ``work'' directory. The following phrase will print the full path of your work directory:"
+"If you look at the output, you will see that a few files were created in your “work” directory. The following phrase will print the full path of your work directory:"
{ $code "\"work\" resource-path ." }
"The work directory is one of several " { $link "vocabs.roots" } " where Factor searches for vocabularies. It is possible to define new vocabulary roots; see " { $link "add-vocab-roots" } ". To keep things simple in this tutorial, we'll just use the work directory, though."
$nl
{ $code ": palindrome? ( string -- ? ) dup reverse = ;" }
"Place this definition at the end of your source file."
$nl
-"Now we have changed the source file, we must reload it into Factor so that we can test the new definition. To do this, simply go to the Factor workspace and press " { $command workspace "workflow" refresh-all } ". This will find any previously-loaded source files which have changed on disk, and reload them."
+"Now we have changed the source file, we must reload it into Factor so that we can test the new definition. To do this, simply go to the Factor listener and press " { $command tool "common" refresh-all } ". This will find any previously-loaded source files which have changed on disk, and reload them."
$nl
"When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
$nl
$nl
"So now, add the following at the start of the source file:"
{ $code "USING: kernel ;" }
-"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the workspace listener's input area, and press " { $operation com-follow } "."
+"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the listener's input area, and press " { $operation com-follow } "."
$nl
"It lives in the " { $vocab-link "sequences" } " vocabulary, so we add that to the search path:"
{ $code "USING: kernel sequences ;" }
"Finally, check what vocabulary " { $link = } " lives in, and confirm that it's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
$nl
-"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
+"Now press " { $command tool "common" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
ARTICLE: "first-program-test" "Testing your first program"
"Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
}
"We will now test our new word in the listener. First, push a string on the stack:"
{ $code "\"hello\"" }
-"Note that the stack display at the top of the workspace now shows this string. Having supplied the input, we call our word:"
+"Note that the stack display in the listener now shows this string. Having supplied the input, we call our word:"
{ $code "palindrome?" }
-"The stack display should now have a boolean false - " { $link f } " - which is the word's output. Since ``hello'' is not a palindrome, this is what we expect. We can get rid of this boolean by calling " { $link drop } ". The stack should be empty after this is done."
+"The stack display should now have a boolean false - " { $link f } " - which is the word's output. Since “hello” is not a palindrome, this is what we expect. We can get rid of this boolean by calling " { $link drop } ". The stack should be empty after this is done."
$nl
"Now, let's try it with a palindrome; we will push the string and call the word in the same line of code:"
{ $code "\"racecar\" palindrome?" }
{ $code "filter" }
"Now the stack should contain the following string:"
{ "\"AmanaplanacanalPanama\"" }
-"This is almost what we want; we just need to convert the string to lower case now. This can be done by calling " { $link >lower } "; the " { $snippet ">" } " prefix is a naming convention for conversion operations, and should be read as ``to'':"
+"This is almost what we want; we just need to convert the string to lower case now. This can be done by calling " { $link >lower } "; the " { $snippet ">" } " prefix is a naming convention for conversion operations, and should be read as “to”:"
{ $code ">lower" }
"Finally, let's print the top of the stack and discard it:"
{ $code "." }
$nl
"We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
{ $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" }
-"Now if you press " { $command workspace "workflow" refresh-all } ", the source file should reload without any errors. You can run unit tests again, and this time, they will all pass:"
+"Now if you press " { $command tool "common" refresh-all } ", the source file should reload without any errors. You can run unit tests again, and this time, they will all pass:"
{ $code "\"palindrome\" test" } ;
ARTICLE: "first-program" "Your first program"
"In this tutorial, we will write a simple Factor program which prompts the user to enter a word, and tests if it is a palindrome (that is, the word is spelled the same backwards and forwards)."
$nl
-"In this tutorial, you will learn about basic Factor development tools. You may want to open a second workspace window by pressing " { $command workspace "workflow" workspace-window } "; this will allow you to read this tutorial and browse other documentation at the same time."
+"In this tutorial, you will learn about basic Factor development tools."
{ $subsection "first-program-start" }
{ $subsection "first-program-logic" }
{ $subsection "first-program-test" }
[
[
"car"
- H{ { font "monospace" } }
+ H{ { font-name "monospace" } }
format
] make-html-string
] unit-test
{
{ foreground fg-css, }
{ background bg-css, }
- { font font-css, }
+ { font-name font-css, }
{ font-style style-css, }
{ font-size size-css, }
} make-css ;
-USING: help.markup help.syntax kernel classes io io.styles mirrors ;
+USING: help.markup help.syntax kernel classes io io.styles mirrors
+inspector.private ;
IN: inspector
ARTICLE: "inspector" "The inspector"
{ $subsection &delete }
"A variable holding the current object:"
{ $subsection me }
-"A variable holding inspector history:"
-{ $subsection inspector-stack }
-"A customization hook:"
-{ $subsection inspector-hook }
"A description of an object can be printed without starting the inspector:"
-{ $subsection describe }
-{ $subsection describe* } ;
+{ $subsection describe } ;
ABOUT: "inspector"
-HELP: value-editor
-{ $values { "path" "a sequence of keys" } }
-{ $description "Prettyprints the value at a path, and if the output stream supports it, a graphical gadget for editing the object." }
-{ $notes "To learn about paths, see " { $link "mirrors" } "." } ;
-
-{ presented-path presented-printer value-editor } related-words
-
HELP: describe
{ $values { "obj" object } }
{ $description "Print a tabular overview of the object."
"For sequences and hashtables, this outputs the entries of the collection. For all other object types, slot names and values are shown." }
{ $examples { $code "global describe" } } ;
-HELP: describe*
-{ $values { "obj" object } { "mirror" mirror } { "keys" "a sequence of objects" } }
-{ $description "Print a tabular overview of the object." }
-{ $notes "This word is a factor of " { $link describe } " and " { $link inspect } "." } ;
-
HELP: inspector-stack
{ $var-description "If the inspector is running, this variable holds previously-inspected objects." } ;
HELP: me
{ $var-description "The currently inspected object." } ;
-
-HELP: inspector-hook
-{ $var-description "A quotation with stack effect " { $snippet "( obj -- )" } ", called by the inspector to display an overview of an object."
-$nl
-"The default implementation calls " { $link describe } " which outputs on " { $link output-stream } ", but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;
[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test
-[ ] [ inspector-hook get-global inspector-hook set ] unit-test
-
[ ] [ H{ } clone inspect ] unit-test
[ ] [ "a" "b" &add ] unit-test
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic hashtables io kernel assocs math
-namespaces prettyprint sequences strings io.styles vectors words
-quotations mirrors splitting math.parser classes vocabs refs
-sets sorting summary debugger continuations fry ;
+namespaces prettyprint prettyprint.custom prettyprint.sections
+sequences strings io.styles vectors words quotations mirrors
+splitting math.parser classes vocabs sets sorting summary
+debugger continuations fry combinators ;
IN: inspector
-: value-editor ( path -- )
- [
- [ pprint-short ] presented-printer set
- dup presented-path set
- ] H{ } make-assoc
- [ get-ref pprint-short ] with-nesting ;
-
-SYMBOL: +sequence+
SYMBOL: +number-rows+
-SYMBOL: +editable+
-: write-slot-editor ( path -- )
- [
- +editable+ get [
- value-editor
- ] [
- get-ref pprint-short
- ] if
- ] with-cell ;
+: summary. ( obj -- ) [ summary ] keep write-object nl ;
-: write-key ( mirror key -- )
- +sequence+ get
- [ 2drop ] [ <key-ref> write-slot-editor ] if ;
+<PRIVATE
-: write-value ( mirror key -- )
- <value-ref> write-slot-editor ;
+: sort-unparsed-keys ( assoc -- alist )
+ >alist dup keys
+ [ unparse-short ] map
+ zip sort-values keys ;
-: describe-row ( mirror key n -- )
- [
- +number-rows+ get [ pprint-cell ] [ drop ] if
- [ write-key ] [ write-value ] 2bi
- ] with-row ;
+GENERIC: add-numbers ( alist -- table' )
-: summary. ( obj -- ) [ summary ] keep write-object nl ;
+M: enum add-numbers ;
+
+M: assoc add-numbers
+ +number-rows+ get [
+ dup length [ prefix ] 2map
+ ] when ;
+
+TUPLE: slot-name name ;
+
+M: slot-name pprint* name>> text ;
-: sorted-keys ( assoc -- alist )
- dup hashtable? [
- keys
- [ [ unparse-short ] keep ] { } map>assoc
- sort-keys values
- ] [ keys ] if ;
-
-: describe* ( obj mirror keys -- )
- [ summary. ] 2dip
- [ drop ] [
- dup enum? [ +sequence+ on ] when
- standard-table-style [
- swap '[ [ _ ] 2dip describe-row ] each-index
- ] tabular-output
- ] if-empty ;
-
-: describe ( obj -- )
- dup make-mirror dup sorted-keys describe* ;
+GENERIC: fix-slot-names ( assoc -- assoc )
+
+M: assoc fix-slot-names >alist ;
+
+M: mirror fix-slot-names
+ [ [ slot-name boa ] dip ] { } assoc-map-as ;
+
+: (describe) ( obj assoc -- keys )
+ t pprint-string-cells? [
+ [ summary. ] [
+ dup hashtable? [ sort-unparsed-keys ] when
+ [ fix-slot-names add-numbers simple-table. ] [ keys ] bi
+ ] bi*
+ ] with-variable ;
+
+PRIVATE>
+
+: describe ( obj -- ) dup make-mirror (describe) drop ;
M: tuple error. describe ;
: :vars ( -- )
error-continuation get name>> namestack. ;
-SYMBOL: inspector-hook
+SYMBOL: me
-[ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global
+<PRIVATE
SYMBOL: inspector-stack
-SYMBOL: me
+SYMBOL: sorted-keys
: reinspect ( obj -- )
[ me set ]
[
- dup make-mirror dup mirror set dup sorted-keys dup \ keys set
- inspector-hook get call
+ dup make-mirror dup mirror set
+ t +number-rows+ [ (describe) ] with-variable
+ sorted-keys set
] bi ;
: (inspect) ( obj -- )
[ inspector-stack get push ] [ reinspect ] bi ;
-: key@ ( n -- key ) \ keys get nth ;
+PRIVATE>
+
+: key@ ( n -- key ) sorted-keys get nth ;
: &push ( -- obj ) me get ;
: &back ( -- )
inspector-stack get
- dup length 1 <= [ drop ] [ dup pop* peek reinspect ] if ;
+ dup length 1 <= [ drop ] [ [ pop* ] [ peek reinspect ] bi ] if ;
: &add ( value key -- ) mirror get set-at &push reinspect ;
USING: help.markup help.syntax io.streams.plain io strings
-hashtables kernel quotations ;
+hashtables kernel quotations colors ;
IN: io.styles
HELP: stream-format
"Character styles for " { $link stream-format } " and " { $link with-style } ":"
{ $subsection foreground }
{ $subsection background }
-{ $subsection font }
+{ $subsection font-name }
{ $subsection font-size }
{ $subsection font-style }
{ $subsection presented } ;
"The " { $link presented } " style can be used to emit clickable objects. A utility word for outputting this style:"
{ $subsection write-object } ;
-ARTICLE: "styles" "Styled text"
+ARTICLE: "styles" "Text styles"
"The " { $link stream-format } ", " { $link with-style } ", " { $link with-nesting } " and " { $link tabular-output } " words take a hashtable of style attributes. Output stream implementations are free to ignore style information."
$nl
"Style hashtables are keyed by symbols from the " { $vocab-link "io.styles" } " vocabulary."
{ $description "A value for the " { $link font-style } " character style denoting boldface italicized text." } ;
HELP: foreground
-{ $description "Character style. Text color, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
+{ $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
{ $examples
{ $code
"10 ["
- " \"Hello world\" swap"
- " { 0.1 0.1 0.2 1 } n*v { 1 1 1 1 } vmin"
- " foreground associate format nl"
+ " \"Hello world\\n\""
+ " swap 10 / 1 <gray> foreground associate format"
"] each"
}
} ;
HELP: background
-{ $description "Character style. Background color, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
+{ $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
{ $examples
{ $code
"10 ["
- " \"Hello world\" swap"
- " { 0.1 0.4 0.1 } n*v { 1 1 1 } vmin { 1 } append"
+ " \"Hello world\\n\""
+ " swap 10 / 1 1 over - over 1 <rgba>"
" background associate format nl"
"] each"
}
} ;
-HELP: font
+HELP: font-name
{ $description "Character style. Font family named by a string." }
{ $examples
"This example outputs some different font sizes:"
- { $code "{ \"monospace\" \"serif\" \"sans-serif\" }\n[ dup font associate format nl ] each" }
+ { $code "{ \"monospace\" \"serif\" \"sans-serif\" }\n[ dup font-name associate format nl ] each" }
} ;
HELP: font-size
HELP: presented
{ $description "Character and paragraph style. An object associated with the text. In the Factor UI, this is shown as a clickable presentation of the object; left-clicking invokes a default command, and right-clicking shows a menu of commands." } ;
-HELP: presented-path
-{ $description "Character and paragraph style. An editable object associated with the text. In the Factor UI, this is shown as a clickable presentation of the object path together with an expander button which displays an object editor; left-clicking invokes a default command, and right-clicking shows a menu of commands." } ;
-
-HELP: presented-printer
-{ $description "Character and paragraph style. A quotation with stack effect " { $snippet "( obj -- )" } " which is applied to the value at the " { $link presented-path } " if the presentation needs to be re-displayed after the object has been edited." } ;
-
HELP: page-color
-{ $description "Paragraph style. Background color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
+{ $description "Paragraph style. An instance of " { $link color } ". See " { $link "colors" } "." }
{ $examples
- { $code "H{ { page-color { 1 0.8 0.5 1 } } }\n[ \"A background\" write ] with-nesting nl" }
+ { $code "H{ { page-color T{ rgba f 1 0.8 0.5 1 } } }\n[ \"A background\" write ] with-nesting nl" }
} ;
HELP: border-color
-{ $description "Paragraph style. Border color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." }
+{ $description "Paragraph style. An instance of " { $link color } ". See " { $link "colors" } "." }
{ $examples
- { $code "H{ { border-color { 1 0 0 1 } } }\n[ \"A border\" write ] with-nesting nl" }
+ { $code "H{ { border-color T{ rgba f 1 0 0 1 } } }\n[ \"A border\" write ] with-nesting nl" }
} ;
HELP: border-width
-{ $description "Paragraph style. Pixels between edge of text and border color, an integer." }
+{ $description "Paragraph style. Pixels between edge of text and border, an integer." }
{ $examples
{ $code "H{ { border-width 10 } }\n[ \"Some inset text\" write ] with-nesting nl" }
} ;
{ table-gap table-border stream-write-table tabular-output } related-words
HELP: table-border
-{ $description "Table style. Color of the border drawn between cells, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." } ;
+{ $description "Table style. An instance of " { $link color } ". See " { $link "colors" } "." } ;
HELP: input
{ $class-description "Class of input text presentations. Instances can be used passed to " { $link write-object } " to output a clickable piece of input. Input text presentations are created by calling " { $link <input> } "." }
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io io.streams.plain io.streams.string
colors summary make accessors splitting math.order
-kernel namespaces assocs destructors strings sequences ;
+kernel namespaces assocs destructors strings sequences
+present fry strings.tables ;
IN: io.styles
GENERIC: stream-format ( str style stream -- )
M: plain-writer make-block-stream
nip <ignore-close-stream> ;
-: format-column ( seq ? -- seq )
- [
- [ 0 [ length max ] reduce ] keep
- swap [ CHAR: \s pad-tail ] curry map
- ] unless ;
-
-: map-last ( seq quot -- seq )
- [ dup length <reversed> ] dip [ 0 = ] prepose 2map ; inline
-
-: format-table ( table -- seq )
- flip [ format-column ] map-last
- flip [ " " join ] map ;
-
M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-output-stream* ;
! Character styles
SYMBOL: foreground
SYMBOL: background
-SYMBOL: font
+SYMBOL: font-name
SYMBOL: font-size
SYMBOL: font-style
! Presentation
SYMBOL: presented
-SYMBOL: presented-path
-SYMBOL: presented-printer
SYMBOL: href
C: <input> input
+M: input present string>> ;
+
M: input summary
[
"Input: " %
- string>> "\n" split1 swap %
- "..." "" ? %
+ string>> "\n" split1
+ [ % ] [ "..." "" ? % ] bi*
] "" make ;
: write-object ( str obj -- ) presented associate format ;
! Copyright (C) 2004, 2005 Mackenzie Straight
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2009 Slava Pestov
! Copyright (C) 2007, 2008 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: alien assocs continuations destructors kernel
+USING: alien assocs continuations alien.destructors kernel
namespaces accessors sets summary ;
IN: libc
<PRIVATE
-: add-malloc ( alien -- )
- mallocs conjoin ;
+: add-malloc ( alien -- alien )
+ dup mallocs conjoin ;
: delete-malloc ( alien -- )
[
mallocs delete-at*
- [ double-free ] unless drop
+ [ drop ] [ double-free ] if
] when* ;
: malloc-exists? ( alien -- ? )
PRIVATE>
: malloc ( size -- alien )
- (malloc) check-ptr
- dup add-malloc ;
+ (malloc) check-ptr add-malloc ;
: calloc ( count size -- alien )
- (calloc) check-ptr
- dup add-malloc ;
+ (calloc) check-ptr add-malloc ;
: realloc ( alien size -- newalien )
over malloc-exists? [ realloc-error ] unless
- dupd (realloc) check-ptr
- swap delete-malloc
- dup add-malloc ;
+ [ drop ] [ (realloc) check-ptr ] 2bi
+ [ delete-malloc ] [ add-malloc ] bi* ;
: free ( alien -- )
- dup delete-malloc
- (free) ;
+ [ delete-malloc ] [ (free) ] bi ;
: memcpy ( dst src size -- )
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;
: strlen ( alien -- len )
"size_t" "libc" "strlen" { "char*" } alien-invoke ;
-<PRIVATE
-
-! Memory allocations
-TUPLE: memory-destructor alien disposed ;
-
-M: memory-destructor dispose* alien>> free ;
-
-PRIVATE>
-
-: &free ( alien -- alien )
- dup f memory-destructor boa &dispose drop ; inline
-
-: |free ( alien -- alien )
- dup f memory-destructor boa |dispose drop ; inline
+DESTRUCTOR: free
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays fry kernel models.compose models.filter sequences ;
+IN: models.search
+
+: <search> ( values search quot -- model )
+ [ 2array <compose> ] dip
+ '[ first2 _ curry filter ] <filter> ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays fry kernel models.compose models.filter
+sequences sorting ;
+IN: models.sort
+
+: <sort> ( values sort -- model )
+ 2array <compose> [ first2 sort ] <filter> ;
\ No newline at end of file
{ $subsection "opengl-geometric-primitives" }
{ $subsection "opengl-modeling-transformations" } ;
-ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
+ARTICLE: "opengl-specifying-vertices" "Specifying vertices"
{ $subsection glVertex2d }
{ $subsection glVertex2f }
{ $subsection glVertex4iv }
{ $subsection glVertex4sv } ;
-ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
+ARTICLE: "opengl-geometric-primitives" "OpenGL geometric primitives"
{ $table
{ { $link GL_POINTS } "individual points" }
{ $link GL_LINE }
{ $link GL_FILL } } } } } ;
-ARTICLE: "opengl-modeling-transformations" "Modeling Transformations"
+ARTICLE: "opengl-modeling-transformations" "Modeling transformations"
{ $subsection glTranslatef }
{ $subsection glTranslated }
{ $subsection glRotatef }
-USING: help.markup help.syntax io kernel math quotations
-opengl.gl assocs vocabs.loader sequences accessors ;
+USING: alien help.markup help.syntax io kernel math quotations
+opengl.gl assocs vocabs.loader sequences accessors colors ;
IN: opengl
HELP: gl-color
-{ $values { "color" "a color specifier" } }
-{ $description "Wrapper for " { $link glColor4d } " taking a color specifier." } ;
+{ $values { "color" color } }
+{ $description "Wrapper for " { $link glColor4d } " taking an instance of " { $link color } "." }
+{ $notes "See " { $link "colors" } "." } ;
HELP: gl-error
{ $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
{ $values { "bits" integer } { "quot" quotation } }
{ $description "Wraps a quotation in " { $link glPushAttrib } "/" { $link glPopAttrib } " calls." } ;
-HELP: sprite
-{ $class-description "A sprite is an OpenGL texture together with a display list which renders a textured quad. Sprites are used to draw text in the UI. Sprites have the following slots:"
- { $list
- { { $snippet "dlist" } " - an OpenGL display list ID" }
- { { $snippet "texture" } " - an OpenGL texture ID" }
- { { $snippet "loc" } " - top-left corner of the sprite" }
- { { $snippet "dim" } " - dimensions of the sprite" }
- { { $snippet "dim2" } " - dimensions of the sprite, rounded up to the nearest powers of two" }
- }
-} ;
-
-HELP: gray-texture
-{ $values { "sprite" sprite } { "pixmap" "an alien or byte array" } { "id" "an OpenGL texture ID" } }
-{ $description "Creates a new OpenGL texture from a 1 byte per pixel image whose dimensions are equal to " { $snippet "dim2" } "." } ;
-
+HELP: make-texture
+{ $values { "dim" "a pair of integers" } { "pixmap" c-ptr } { "format" "an OpenGL texture format, for example " { $link GL_UNSIGNED_BYTE } } { "type" "an OpenGL texture type, for example " { $link GL_RGBA } } { "id" "an OpenGL texture ID" } }
+{ $description "Creates a new OpenGL texture from a pixmap image whose dimensions are equal to " { $snippet "dim" } "." } ;
+
HELP: gen-dlist
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glGenLists } " to handle the common case of generating a single display list ID." } ;
{ $values { "point" "a pair of integers" } }
{ $description "Wrapper for " { $link glTranslated } " taking a point object." } ;
-HELP: free-sprites
-{ $values { "sprites" "a sequence of " { $link sprite } " instances" } }
-{ $description "Deallocates native resources associated toa sequence of sprites." } ;
-
HELP: with-translation
{ $values { "loc" "a pair of integers" } { "quot" quotation } }
{ $description "Calls the quotation with a translation by " { $snippet "loc" } " pixels applied to the current " { $link GL_MODELVIEW } " matrix, restoring the matrix when the quotation is done." } ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! Portions copyright (C) 2007 Eduardo Cavazos.
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
specialized-arrays.uint ;
IN: opengl
-: color>raw ( object -- r g b a )
- >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
+: gl-color ( color -- ) >rgba-components glColor4d ; inline
-: gl-color ( color -- ) color>raw glColor4d ; inline
-
-: gl-clear-color ( color -- ) color>raw glClearColor ;
+: gl-clear-color ( color -- ) >rgba-components glClearColor ;
: gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
[ glDisableClientState ] each ; inline
MACRO: all-enabled ( seq quot -- )
- [ words>values ] dip [ (all-enabled) ] 2curry ;
+ [ words>values ] dip '[ _ _ (all-enabled) ] ;
MACRO: all-enabled-client-state ( seq quot -- )
- [ words>values ] dip [ (all-enabled-client-state) ] 2curry ;
+ [ words>values ] dip '[ _ (all-enabled-client-state) ] ;
: do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep
[ length ] [ >uint-array underlying>> ] bi glDrawBuffers ;
MACRO: set-draw-buffers ( buffers -- )
- words>values [ (set-draw-buffers) ] curry ;
+ words>values '[ _ (set-draw-buffers) ] ;
: do-attribs ( bits quot -- )
swap glPushAttrib call glPopAttrib ; inline
: gl-look-at ( eye focus up -- )
[ first3 ] tri@ gluLookAt ;
-TUPLE: sprite loc dim dim2 dlist texture ;
-
-: <sprite> ( loc dim dim2 -- sprite )
- f f sprite boa ;
-
-: sprite-size2 ( sprite -- w h ) dim2>> first2 ;
-
-: sprite-width ( sprite -- w ) dim>> first ;
-
-: gray-texture ( sprite pixmap -- id )
+:: make-texture ( dim pixmap format type -- id )
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
- [
- [ GL_TEXTURE_2D 0 GL_RGBA ] dip
- sprite-size2 0 GL_LUMINANCE_ALPHA
- GL_UNSIGNED_BYTE
- ] dip glTexImage2D
+ GL_TEXTURE_2D
+ 0
+ GL_RGBA
+ dim first2
+ 0
+ format
+ type
+ pixmap
+ glTexImage2D
] do-attribs
] keep ;
-
+
: gen-dlist ( -- id ) 1 glGenLists ;
: make-dlist ( type quot -- id )
- gen-dlist [ rot glNewList call glEndList ] keep ; inline
+ [ gen-dlist ] 2dip '[ _ glNewList @ glEndList ] keep ; inline
: init-texture ( -- )
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
: rect-texture-coords ( -- )
float-array{ 0 0 1 0 1 1 0 1 } gl-texture-coord-pointer ;
-: draw-sprite ( sprite -- )
- GL_TEXTURE_COORD_ARRAY [
- dup loc>> gl-translate
- GL_TEXTURE_2D over texture>> glBindTexture
- init-texture rect-texture-coords
- dim2>> fill-rect-vertices
- (gl-fill-rect)
- GL_TEXTURE_2D 0 glBindTexture
- ] do-enabled-client-state ;
-
-: make-sprite-dlist ( sprite -- id )
- GL_MODELVIEW [
- GL_COMPILE [ draw-sprite ] make-dlist
- ] do-matrix ;
-
-: init-sprite ( texture sprite -- )
- swap >>texture
- dup make-sprite-dlist >>dlist drop ;
-
: delete-dlist ( id -- ) 1 glDeleteLists ;
-: free-sprite ( sprite -- )
- [ dlist>> delete-dlist ]
- [ texture>> delete-texture ] bi ;
-
-: free-sprites ( sprites -- )
- [ nip [ free-sprite ] when* ] assoc-each ;
-
: with-translation ( loc quot -- )
GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode
- glLoadIdentity ;
+ glLoadIdentity ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: opengl.sprites
+USING: help.markup help.syntax ;
+
+HELP: sprite
+{ $class-description "A sprite is an OpenGL texture together with a display list which renders a textured quad. Sprites are used to draw text in the UI. Sprites have the following slots:"
+ { $list
+ { { $snippet "dlist" } " - an OpenGL display list ID" }
+ { { $snippet "texture" } " - an OpenGL texture ID" }
+ { { $snippet "loc" } " - top-left corner of the sprite" }
+ { { $snippet "dim" } " - dimensions of the sprite" }
+ { { $snippet "dim2" } " - dimensions of the sprite, rounded up to the nearest powers of two" }
+ }
+} ;
+
+HELP: free-sprites
+{ $values { "sprites" "a sequence of " { $link sprite } " instances" } }
+{ $description "Deallocates native resources associated toa sequence of sprites." } ;
+
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test opengl.sprites ;
+IN: opengl.sprites.tests
--- /dev/null
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences opengl opengl.gl assocs ;
+IN: opengl.sprites
+
+TUPLE: sprite loc dim dim2 dlist texture ;
+
+: <sprite> ( loc dim dim2 -- sprite )
+ f f sprite boa ;
+
+: sprite-size2 ( sprite -- w h ) dim2>> first2 ;
+
+: sprite-width ( sprite -- w ) dim>> first ;
+
+: draw-sprite ( sprite -- )
+ GL_TEXTURE_COORD_ARRAY [
+ dup loc>> gl-translate
+ GL_TEXTURE_2D over texture>> glBindTexture
+ init-texture rect-texture-coords
+ dim2>> fill-rect-vertices
+ (gl-fill-rect)
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-enabled-client-state ;
+
+: make-sprite-dlist ( sprite -- id )
+ GL_MODELVIEW [
+ GL_COMPILE [ draw-sprite ] make-dlist
+ ] do-matrix ;
+
+: init-sprite ( texture sprite -- )
+ swap >>texture
+ dup make-sprite-dlist >>dlist drop ;
+
+: free-sprite ( sprite -- )
+ [ dlist>> delete-dlist ]
+ [ texture>> delete-texture ] bi ;
+
+: free-sprites ( sprites -- )
+ [ nip [ free-sprite ] when* ] assoc-each ;
\ No newline at end of file
--- /dev/null
+IN: present.tests
+USING: tools.test present math vocabs tools.vocabs sequences kernel ;
+
+[ "3" ] [ 3 present ] unit-test
+[ "Hi" ] [ "Hi" present ] unit-test
+[ "+" ] [ \ + present ] unit-test
+[ "kernel" ] [ "kernel" vocab present ] unit-test
+[ ] [ all-vocabs-seq [ present ] map drop ] unit-test
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math math.parser strings words kernel effects ;
+USING: accessors math math.parser strings words vocabs
+kernel effects ;
IN: present
GENERIC: present ( object -- string )
M: word present name>> ;
+M: vocab-spec present name>> ;
+
M: effect present effect>string ;
M: f present drop "" ;
: .c ( -- ) callstack callstack. ;
-: pprint-cell ( obj -- ) [ pprint ] with-cell ;
+: pprint-cell ( obj -- ) [ pprint-short ] with-cell ;
+
+SYMBOL: pprint-string-cells?
: simple-table. ( values -- )
standard-table-style [
[
[
[
- dup string?
+ dup string? pprint-string-cells? get not and
[ [ write ] with-cell ]
[ pprint-cell ]
if
M: word summary synopsis ;
-: synopsis-alist ( definitions -- alist )
- [ dup synopsis swap ] { } map>assoc ;
-
-: definitions. ( alist -- )
- [ write-object nl ] assoc-each ;
-
-: sorted-definitions. ( definitions -- )
- synopsis-alist sort-keys definitions. ;
-
GENERIC: declarations. ( obj -- )
M: object declarations. drop ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test strings.tables ;
+IN: strings.tables.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences fry ;
+IN: strings.tables
+
+<PRIVATE
+
+: format-column ( seq ? -- seq )
+ [
+ dup [ length ] map supremum
+ '[ _ CHAR: \s pad-tail ] map
+ ] unless ;
+
+: map-last ( seq quot -- seq )
+ [ dup length <reversed> ] dip '[ 0 = @ ] 2map ; inline
+
+PRIVATE>
+
+: format-table ( table -- seq )
+ flip [ format-column ] map-last
+ flip [ " " join ] map ;
\ No newline at end of file
--- /dev/null
+IN: tools.apropos
+USING: help.markup help.syntax strings ;
+
+HELP: apropos
+{ $values { "str" string } }
+{ $description "Lists all words, vocabularies and help articles whose name contains a subsequence equal to " { $snippet "str" } ". Results are ranked using a simple distance algorithm." } ;
--- /dev/null
+IN: tools.apropos.tests
+USING: tools.apropos tools.test ;
+
+[ ] [ "swp" apropos ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs fry help.markup help.topics io
+kernel make math math.parser namespaces sequences sorting
+summary tools.completion tools.vocabs tools.vocabs.browser
+vocabs words unicode.case help ;
+IN: tools.apropos
+
+: $completions ( seq -- )
+ dup [ word? ] all? [ words-table ] [
+ dup [ vocab-spec? ] all? [
+ $vocabs
+ ] [
+ [ <$link> ] map $list
+ ] if
+ ] if ;
+
+TUPLE: more-completions seq ;
+
+CONSTANT: max-completions 5
+
+M: more-completions article-title
+ seq>> length number>string " results" append ;
+
+M: more-completions article-name
+ seq>> length max-completions - number>string " more results" append ;
+
+M: more-completions article-content
+ seq>> sort-values keys \ $completions prefix ;
+
+M: more-completions summary article-title ;
+
+: (apropos) ( str candidates title -- element )
+ [
+ [ completions ] dip '[
+ _ 1array \ $heading prefix ,
+ [ max-completions short head keys \ $completions prefix , ]
+ [ dup length max-completions > [ more-completions boa <$link> , ] [ drop ] if ]
+ bi
+ ] unless-empty
+ ] { } make ;
+
+: word-candidates ( words -- candidates )
+ [ dup name>> >lower ] { } map>assoc ;
+
+: vocab-candidates ( -- candidates )
+ all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
+
+: help-candidates ( seq -- candidates )
+ [ [ >link ] [ article-title >lower ] bi ] { } map>assoc
+ sort-values ;
+
+: $apropos ( str -- )
+ first
+ [ all-words word-candidates "Words" (apropos) ]
+ [ vocab-candidates "Vocabularies" (apropos) ]
+ [ articles get keys help-candidates "Help articles" (apropos) ]
+ tri 3array print-element ;
+
+TUPLE: apropos search ;
+
+C: <apropos> apropos
+
+M: apropos article-title
+ search>> "Search results for “" "”" surround ;
+
+M: apropos article-name article-title ;
+
+M: apropos article-content
+ search>> 1array \ $apropos prefix ;
+
+: apropos ( str -- )
+ <apropos> print-topic ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math namespaces strings io
-vectors words assocs combinators sorting unicode.case
-unicode.categories math.order ;
+USING: accessors kernel arrays sequences math namespaces
+strings io fry vectors words assocs combinators sorting
+unicode.case unicode.categories math.order vocabs
+tools.vocabs ;
IN: tools.completion
: (fuzzy) ( accum ch i full -- accum i ? )
- index-from
+ index-from
[
[ swap push ] 2keep 1+ t
] [
dupd fuzzy score max ;
: completion ( short candidate -- result )
- [ second >lower swap complete ] keep first 2array ;
+ [ second >lower swap complete ] keep 2array ;
: completions ( short candidates -- seq )
- over empty? [
- nip [ first ] map
- ] [
- [ >lower ] dip [ completion ] with map
- rank-completions
- ] if ;
+ [ '[ _ ] ]
+ [ '[ >lower _ [ completion ] with map rank-completions ] ] bi
+ if-empty ;
+
+: name-completions ( str seq -- seq' )
+ [ dup name>> ] { } map>assoc completions ;
-: string-completions ( short strs -- seq )
- dup zip completions ;
+: words-matching ( str -- seq )
+ all-words name-completions ;
-: limited-completions ( short candidates -- seq )
- [ completions ] [ drop ] 2bi
- 2dup [ length 50 > ] [ empty? ] bi* and
- [ 2drop f ] [ drop 50 short head ] if ;
+: vocabs-matching ( str -- seq )
+ all-vocabs-seq name-completions ;
\ No newline at end of file
ARTICLE: "tools.crossref" "Cross-referencing tools"
{ $subsection usage. }
-{ $subsection apropos }
{ $see-also "definitions" "words" see see-methods } ;
ABOUT: "tools.crossref"
{ $examples { $code "\\ reverse usage." } } ;
{ usage usage. } related-words
-
-HELP: apropos
-{ $values { "str" "a string" } }
-{ $description "Lists all words whose name contains a subsequence equal to " { $snippet "str" } ". Results are ranked using a simple distance algorithm." } ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions assocs io kernel
-math namespaces prettyprint sequences strings io.styles words
-generic tools.completion quotations parser summary
-sorting hashtables vocabs parser source-files ;
+USING: assocs definitions io io.styles kernel prettyprint
+sorting ;
IN: tools.crossref
-: usage. ( word -- )
- smart-usage sorted-definitions. ;
+: synopsis-alist ( definitions -- alist )
+ [ dup synopsis swap ] { } map>assoc ;
+
+: definitions. ( alist -- )
+ [ write-object nl ] assoc-each ;
-: words-matching ( str -- seq )
- all-words [ dup name>> ] { } map>assoc completions ;
+: sorted-definitions. ( definitions -- )
+ synopsis-alist sort-keys definitions. ;
-: apropos ( str -- )
- words-matching synopsis-alist reverse definitions. ;
+: usage. ( word -- )
+ smart-usage sorted-definitions. ;
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files io.files.info.unix io.pathnames
io.directories io.directories.hierarchy kernel namespaces make
: copy-dll ( bundle-name -- )
"Frameworks/libfactor.dylib" copy-bundle-dir ;
-: copy-freetype ( bundle-name -- )
- deploy-ui? get [ "Frameworks" copy-bundle-dir ] [ drop ] if ;
-
: copy-nib ( bundle-name -- )
deploy-ui? get [
"Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
: create-app-dir ( vocab bundle-name -- vm )
[
- nip {
- [ copy-dll ]
- [ copy-freetype ]
- [ copy-nib ]
- [ "Contents/Resources/" copy-fonts ]
- [ "Contents/Resources" append-path make-directories ]
- } cleave
+ nip
+ [ copy-dll ]
+ [ copy-nib ]
+ [ "Contents/Resources" append-path make-directories ]
+ tri
]
[ create-app-plist ]
[ "Contents/MacOS/" append-path "" copy-vm ] 2tri
ABOUT: "profiling"
HELP: counters
-{ $values { "words" "a sequence of words" } { "assoc" "an association list mapping words to integers" } }
+{ $values { "words" "a sequence of words" } { "alist" "an association list mapping words to integers" } }
{ $description "Outputs an association list of word call counts." } ;
HELP: counters.
USING: accessors words sequences math prettyprint kernel arrays io
io.styles namespaces assocs kernel.private strings combinators
sorting math.parser vocabs definitions tools.profiler.private
-continuations generic compiler.units sets ;
+continuations generic compiler.units sets classes fry ;
IN: tools.profiler
: profile ( quot -- )
[ t profiling call ] [ f profiling ] [ ] cleanup ;
-: counters ( words -- assoc )
- [ dup counter>> ] { } map>assoc ;
+: filter-counts ( alist -- alist' )
+ [ second 0 > ] filter ;
-GENERIC: (profile.) ( obj -- )
+: map-counters ( obj quot -- alist )
+ { } map>assoc filter-counts ; inline
-TUPLE: usage-profile word ;
+: counters ( words -- alist )
+ [ dup counter>> ] map-counters ;
-C: <usage-profile> usage-profile
+: cumulative-counters ( obj quot -- alist )
+ '[ dup @ [ counter>> ] sigma ] map-counters ; inline
-M: word (profile.)
- [ name>> "( no name )" or ] [ <usage-profile> ] bi write-object ;
+: vocab-counters ( -- alist )
+ vocabs [ words [ predicate? not ] filter ] cumulative-counters ;
-TUPLE: vocab-profile vocab ;
+: generic-counters ( -- alist )
+ all-words [ subwords ] cumulative-counters ;
-C: <vocab-profile> vocab-profile
+: methods-on ( class -- methods )
+ dup implementors [ method ] with map ;
-M: string (profile.)
- dup <vocab-profile> write-object ;
+: class-counters ( -- alist )
+ classes [ methods-on ] cumulative-counters ;
-M: method-body (profile.)
- [ synopsis ] [ "method-generic" word-prop <usage-profile> ] bi
- write-object ;
+: method-counters ( -- alist )
+ all-words [ subwords ] map concat counters ;
-: counter. ( obj n -- )
- [
- [ [ (profile.) ] with-cell ] dip
- [ number>string write ] with-cell
- ] with-row ;
+: profiler-usage ( word -- words )
+ [ smart-usage [ word? ] filter ]
+ [ compiled-generic-usage keys ]
+ [ compiled-usage keys ]
+ tri 3append prune ;
+
+: usage-counters ( word -- alist )
+ profiler-usage counters ;
: counters. ( assoc -- )
- [ second 0 > ] filter sort-values
standard-table-style [
- [ counter. ] assoc-each
+ sort-values simple-table.
] tabular-output ;
: profile. ( -- )
"Call counts for words which call " write
dup pprint
":" print
- [ smart-usage [ word? ] filter ]
- [ compiled-generic-usage keys ]
- [ compiled-usage keys ]
- tri 3append prune counters counters. ;
+ usage-counters counters. ;
: vocabs-profile. ( -- )
"Call counts for all vocabularies:" print
- vocabs [
- dup words
- [ "predicating" word-prop not ] filter
- [ counter>> ] map sum
- ] { } map>assoc counters. ;
+ vocab-counters counters. ;
+
+: generic-profile. ( -- )
+ "Call counts for methods on generic words:" print
+ generic-counters counters. ;
+
+: class-profile. ( -- )
+ "Call counts for methods on classes:" print
+ class-counters counters. ;
: method-profile. ( -- )
- all-words [ subwords ] map concat
- counters counters. ;
+ "Call counts for all methods:" print
+ method-counters counters. ;
+++ /dev/null
-IN: tools.test.tests
-USING: completion words sequences test ;
-
-[ ] [ "swp" apropos ] unit-test
-[ f ] [ "swp" words-matching empty? ] unit-test
ARTICLE: "vocab-index" "Vocabulary index"
{ $subsection "vocab-tags" }
{ $subsection "vocab-authors" }
-{ $describe-vocab "" } ;
+{ $vocab "" } ;
HELP: words.
{ $values { "vocab" "a vocabulary name" } }
IN: tools.vocabs.browser.tests
-USING: tools.vocabs.browser tools.test help.markup ;
+USING: tools.vocabs.browser tools.test help.markup help vocabs ;
-[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test
+[ ] [ { $vocab "scratchpad" } print-content ] unit-test
+[ ] [ "classes" vocab print-topic ] unit-test
\ No newline at end of file
: vocab-status-string ( vocab -- string )
{
- { [ dup not ] [ drop "" ] }
+ { [ dup vocab not ] [ drop "" ] }
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
[ drop "[Loaded]" ]
} cond ;
-: write-status ( vocab -- )
- vocab vocab-status-string write ;
+: vocab-row ( vocab -- row )
+ [ <$link> ] [ vocab-status-string ] [ vocab-summary ] tri
+ 3array ;
-: vocab. ( vocab -- )
- [
- [ [ write-status ] with-cell ]
- [ [ ($link) ] with-cell ]
- [ [ vocab-summary write ] with-cell ] tri
- ] with-row ;
-
-: vocab-headings. ( -- )
- [
- [ "State" write ] with-cell
- [ "Vocabulary" write ] with-cell
- [ "Summary" write ] with-cell
- ] with-row ;
+: vocab-headings ( -- headings )
+ {
+ { $strong "Vocabulary" }
+ { $strong "State" }
+ { $strong "Summary" }
+ } ;
-: root-heading. ( root -- )
+: root-heading ( root -- )
[ "Children from " prepend ] [ "Children" ] if*
$heading ;
-: $vocabs ( assoc -- )
+: $vocabs ( seq -- )
+ [ vocab-row ] map vocab-headings prefix $table ;
+
+: $vocab-roots ( assoc -- )
[
- [ drop ] [
- [ root-heading. ]
- [
- standard-table-style [
- vocab-headings. [ vocab. ] each
- ] ($grid)
- ] bi*
- ] if-empty
+ [ drop ] [ [ root-heading ] [ $vocabs ] bi* ] if-empty
] assoc-each ;
TUPLE: vocab-tag name ;
] unless-empty ;
: describe-children ( vocab -- )
- vocab-name all-child-vocabs $vocabs ;
+ vocab-name all-child-vocabs $vocab-roots ;
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
[
[ <$link> ]
[ superclass <$link> ]
- [ "slots" word-prop [ name>> ] map " " join \ $snippet swap 2array ]
+ [ "slots" word-prop [ name>> ] map " " join <$snippet> ]
tri 3array
] map
{ { $strong "Class" } { $strong "Superclass" } { $strong "Slots" } } prefix
"Parsing words" $subheading
[
[ <$link> ]
- [ word-syntax dup [ \ $snippet swap 2array ] when ]
+ [ word-syntax dup [ <$snippet> ] when ]
bi 2array
] map
{ { $strong "Word" } { $strong "Syntax" } } prefix
$table
] unless-empty ;
+: words-table ( words -- )
+ [
+ [ <$link> ]
+ [ stack-effect dup [ effect>string <$snippet> ] when ]
+ bi 2array
+ ] map
+ { { $strong "Word" } { $strong "Stack effect" } } prefix
+ $table ;
+
: (describe-words) ( words heading -- )
- '[
- _ $subheading
- [
- [ <$link> ]
- [ stack-effect dup [ effect>string \ $snippet swap 2array ] when ]
- bi 2array
- ] map
- { { $strong "Word" } { $strong "Stack effect" } } prefix
- $table
- ] unless-empty ;
+ '[ _ $subheading words-table ] unless-empty ;
: describe-generics ( words -- )
"Generic words" (describe-words) ;
[ <$link> 1array ] map $table
] unless-empty ;
-: describe-words ( vocab -- )
- words [
+: $words ( words -- )
+ [
"Words" $heading
natural-sort
: words. ( vocab -- )
last-element off
- vocab-name describe-words ;
+ [ require ] [ words $words ] bi ;
: describe-metadata ( vocab -- )
[
] { } make
[ "Meta-data" $heading $table ] unless-empty ;
-: $describe-vocab ( element -- )
+: $vocab ( element -- )
first {
[ describe-help ]
[ describe-metadata ]
- [ describe-words ]
+ [ words $words ]
[ describe-files ]
[ describe-children ]
} cleave ;
[ vocab-authors ] keyed-vocabs ;
: $tagged-vocabs ( element -- )
- first tagged $vocabs ;
+ first tagged $vocab-roots ;
: $authored-vocabs ( element -- )
- first authored $vocabs ;
+ first authored $vocab-roots ;
: $all-tags ( element -- )
drop "Tags" $heading all-tags $tags ;
M: vocab-spec article-name vocab-name ;
M: vocab-spec article-content
- vocab-name \ $describe-vocab swap 2array ;
+ vocab-name \ $vocab swap 2array ;
M: vocab-spec article-parent drop "vocab-index" ;
M: vocab-tag >link ;
M: vocab-tag article-title
- name>> "Vocabularies tagged ``" "''" surround ;
+ name>> "Vocabularies tagged “" "”" surround ;
M: vocab-tag article-name name>> ;
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
-HOOK: beep ui-backend ( -- )
-
: with-gl-context ( handle quot -- )
swap [ select-gl-context call ] keep
glFlush flush-gl-context gl-error ; inline
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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
+cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
+cocoa.windows cocoa.classes cocoa.nibs sequences system ui
+ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
+ui.backend.cocoa.views core-foundation core-foundation.run-loop
+core-graphics.types threads math.geometry.rect fry libc
+generalizations alien.c-types cocoa.views
+combinators io.thread ;
+IN: ui.backend.cocoa
+
+TUPLE: handle ;
+TUPLE: window-handle < handle view window ;
+TUPLE: offscreen-handle < handle context buffer ;
+
+C: <window-handle> window-handle
+C: <offscreen-handle> offscreen-handle
+
+SINGLETON: cocoa-ui-backend
+
+TUPLE: pasteboard handle ;
+
+C: <pasteboard> pasteboard
+
+M: pasteboard clipboard-contents
+ handle>> pasteboard-string ;
+
+M: pasteboard set-clipboard-contents
+ handle>> set-pasteboard-string ;
+
+: init-clipboard ( -- )
+ NSPasteboard -> generalPasteboard <pasteboard>
+ clipboard set-global
+ <clipboard> selection set-global ;
+
+: world>NSRect ( world -- NSRect )
+ [ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ <CGRect> ;
+
+: gadget-window ( world -- )
+ dup <FactorView>
+ 2dup swap world>NSRect <ViewWindow>
+ [ [ -> release ] [ install-window-delegate ] bi* ]
+ [ <window-handle> ] 2bi
+ >>handle drop ;
+
+M: cocoa-ui-backend set-title ( string world -- )
+ handle>> window>> swap <NSString> -> setTitle: ;
+
+: enter-fullscreen ( world -- )
+ handle>> view>>
+ NSScreen -> mainScreen
+ f -> enterFullScreenMode:withOptions:
+ drop ;
+
+: exit-fullscreen ( world -- )
+ handle>> view>> f -> exitFullScreenModeWithOptions: ;
+
+M: cocoa-ui-backend set-fullscreen* ( ? world -- )
+ swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+
+M: cocoa-ui-backend fullscreen* ( world -- ? )
+ handle>> view>> -> isInFullScreenMode zero? not ;
+
+: auto-position ( world -- )
+ dup window-loc>> { 0 0 } = [
+ handle>> window>> -> center
+ ] [
+ drop
+ ] if ;
+
+M: cocoa-ui-backend (open-window) ( world -- )
+ dup gadget-window
+ dup auto-position
+ handle>> window>> f -> makeKeyAndOrderFront: ;
+
+M: cocoa-ui-backend (close-window) ( handle -- )
+ window>> -> release ;
+
+M: cocoa-ui-backend close-window ( gadget -- )
+ find-world [
+ handle>> [
+ window>> f -> performClose:
+ ] when*
+ ] when* ;
+
+M: cocoa-ui-backend raise-window* ( world -- )
+ handle>> [
+ window>> dup f -> orderFront: -> makeKeyWindow
+ NSApp 1 -> activateIgnoringOtherApps:
+ ] when* ;
+
+: pixel-size ( pixel-format -- size )
+ 0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
+ keep *int -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 <PixelFormat>
+ [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
+ [ offscreen-buffer ] 2bi
+ 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
+
+M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
+ dup gadget-offscreen-context <offscreen-handle> >>handle drop ;
+
+M: cocoa-ui-backend (close-offscreen-buffer) ( handle -- )
+ [ context>> -> release ]
+ [ buffer>> free ] bi ;
+
+GENERIC: (gl-context) ( handle -- context )
+M: window-handle (gl-context) view>> -> openGLContext ;
+M: offscreen-handle (gl-context) context>> ;
+
+M: handle select-gl-context ( handle -- )
+ (gl-context) -> makeCurrentContext ;
+
+M: handle flush-gl-context ( handle -- )
+ (gl-context) -> flushBuffer ;
+
+M: cocoa-ui-backend offscreen-pixels ( world -- alien w h )
+ [ handle>> buffer>> ] [ dim>> first2 neg ] bi ;
+
+M: cocoa-ui-backend beep ( -- )
+ NSBeep ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorApplicationDelegate" }
+}
+
+{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+ [ 3drop reset-run-loop ]
+} ;
+
+: install-app-delegate ( -- )
+ NSApp FactorApplicationDelegate install-delegate ;
+
+SYMBOL: cocoa-init-hook
+
+cocoa-init-hook global [
+ [ "MiniFactor.nib" load-nib install-app-delegate ] or
+] change-at
+
+M: cocoa-ui-backend (with-ui)
+ "UI" assert.app [
+ [
+ init-clipboard
+ cocoa-init-hook get call
+ start-ui
+ f io-thread-running? set-global
+ init-thread-timer
+ reset-run-loop
+ NSApp -> run
+ ] ui-running
+ ] with-cocoa ;
+
+cocoa-ui-backend ui-backend set-global
+
+[ running.app? "ui.tools" "listener" ? ] main-vocab-hook set-global
--- /dev/null
+Cocoa UI backend
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+Cocoa integration for UI developer tools
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax cocoa cocoa.nibs cocoa.application
+cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
+core-foundation core-foundation.strings help.topics kernel
+memory namespaces parser system ui ui.tools.browser
+ui.tools.listener ui.backend.cocoa eval locals tools.vocabs ;
+IN: ui.backend.cocoa.tools
+
+: finder-run-files ( alien -- )
+ CF>string-array listener-run-files
+ NSApp NSApplicationDelegateReplySuccess
+ -> replyToOpenOrPrint: ;
+
+: menu-run-files ( -- )
+ open-panel [ listener-run-files ] when* ;
+
+: menu-save-image ( -- )
+ image save-panel [ save-image ] when* ;
+
+! Handle Open events from the Finder
+CLASS: {
+ { +superclass+ "FactorApplicationDelegate" }
+ { +name+ "FactorWorkspaceApplicationDelegate" }
+}
+
+{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
+ [ [ 3drop ] dip finder-run-files ]
+}
+
+{ "factorListener:" "id" { "id" "SEL" "id" }
+ [ 3drop show-listener f ]
+}
+
+{ "factorBrowser:" "id" { "id" "SEL" "id" }
+ [ 3drop show-browser f ]
+}
+
+{ "newFactorListener:" "id" { "id" "SEL" "id" }
+ [ 3drop listener-window f ]
+}
+
+{ "newFactorBrowser:" "id" { "id" "SEL" "id" }
+ [ 3drop browser-window f ]
+}
+
+{ "runFactorFile:" "id" { "id" "SEL" "id" }
+ [ 3drop menu-run-files f ]
+}
+
+{ "saveFactorImage:" "id" { "id" "SEL" "id" }
+ [ 3drop save f ]
+}
+
+{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
+ [ 3drop menu-save-image f ]
+}
+
+{ "refreshAll:" "id" { "id" "SEL" "id" }
+ [ 3drop [ refresh-all ] call-listener f ]
+} ;
+
+: install-app-delegate ( -- )
+ NSApp FactorWorkspaceApplicationDelegate install-delegate ;
+
+! Service support; evaluate Factor code from other apps
+:: do-service ( pboard error quot -- )
+ pboard error ?pasteboard-string
+ dup [ quot call ] when
+ [ pboard set-pasteboard-string ] when* ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorServiceProvider" }
+} {
+ "evalInListener:userData:error:"
+ "void"
+ { "id" "SEL" "id" "id" "id" }
+ [ nip [ eval-listener f ] do-service 2drop ]
+} {
+ "evalToString:userData:error:"
+ "void"
+ { "id" "SEL" "id" "id" "id" }
+ [ nip [ eval>string ] do-service 2drop ]
+} ;
+
+: register-services ( -- )
+ NSApp
+ FactorServiceProvider -> alloc -> init
+ -> setServicesProvider: ;
+
+FUNCTION: void NSUpdateDynamicServices ;
+
+[
+ install-app-delegate
+ "Factor.nib" load-nib
+ register-services
+] cocoa-init-hook set-global
--- /dev/null
+Slava Pestov
--- /dev/null
+Cocoa NSView implementation displaying Factor gadgets
--- /dev/null
+unportable
--- /dev/null
+IN: ui.backend.cocoa.views.tests
+USING: ui.backend.cocoa.views tools.test kernel math.geometry.rect
+namespaces ;
+
+[ t ] [
+ T{ rect
+ { loc { 0 0 } }
+ { dim { 1000 1000 } }
+ } "world" set
+
+ T{ rect
+ { loc { 1.5 2.25 } }
+ { dim { 13.0 14.0 } }
+ } dup "world" get rect>NSRect "world" get NSRect>rect =
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays assocs cocoa kernel
+math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
+cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
+sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
+core-foundation.strings core-graphics core-graphics.types
+threads combinators math.geometry.rect ;
+IN: ui.backend.cocoa.views
+
+: send-mouse-moved ( view event -- )
+ [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
+
+: button ( event -- n )
+ #! Cocoa -> Factor UI button mapping
+ -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
+
+CONSTANT: modifiers
+ {
+ { S+ HEX: 20000 }
+ { C+ HEX: 40000 }
+ { A+ HEX: 100000 }
+ { M+ HEX: 80000 }
+ }
+
+CONSTANT: key-codes
+ H{
+ { 71 "CLEAR" }
+ { 36 "RET" }
+ { 76 "ENTER" }
+ { 53 "ESC" }
+ { 48 "TAB" }
+ { 51 "BACKSPACE" }
+ { 115 "HOME" }
+ { 117 "DELETE" }
+ { 119 "END" }
+ { 122 "F1" }
+ { 120 "F2" }
+ { 99 "F3" }
+ { 118 "F4" }
+ { 96 "F5" }
+ { 97 "F6" }
+ { 98 "F7" }
+ { 100 "F8" }
+ { 123 "LEFT" }
+ { 124 "RIGHT" }
+ { 125 "DOWN" }
+ { 126 "UP" }
+ { 116 "PAGE_UP" }
+ { 121 "PAGE_DOWN" }
+ }
+
+: key-code ( event -- string ? )
+ dup -> keyCode key-codes at
+ [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if ;
+
+: event-modifiers ( event -- modifiers )
+ -> modifierFlags modifiers modifier ;
+
+: key-event>gesture ( event -- modifiers keycode action? )
+ [ event-modifiers ] [ key-code ] bi ;
+
+: send-key-event ( view gesture -- )
+ swap window propagate-key-gesture ;
+
+: interpret-key-event ( view event -- )
+ NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
+
+: send-key-down-event ( view event -- )
+ [ key-event>gesture <key-down> send-key-event ]
+ [ interpret-key-event ]
+ 2bi ;
+
+: send-key-up-event ( view event -- )
+ key-event>gesture <key-up> send-key-event ;
+
+: mouse-event>gesture ( event -- modifiers button )
+ [ event-modifiers ] [ button ] bi ;
+
+: send-button-down$ ( view event -- )
+ [ nip mouse-event>gesture <button-down> ]
+ [ mouse-location ]
+ [ drop window ]
+ 2tri send-button-down ;
+
+: send-button-up$ ( view event -- )
+ [ nip mouse-event>gesture <button-up> ]
+ [ mouse-location ]
+ [ drop window ]
+ 2tri send-button-up ;
+
+: send-wheel$ ( view event -- )
+ [ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ]
+ [ mouse-location ]
+ [ drop window ]
+ 2tri send-wheel ;
+
+: send-action$ ( view event gesture -- junk )
+ [ drop window ] dip send-action f ;
+
+: add-resize-observer ( observer object -- )
+ [
+ "updateFactorGadgetSize:"
+ "NSViewFrameDidChangeNotification" <NSString>
+ ] dip add-observer ;
+
+: string-or-nil? ( NSString -- ? )
+ [ CF>string NSStringPboardType = ] [ t ] if* ;
+
+: valid-service? ( gadget send-type return-type -- ? )
+ 2dup [ string-or-nil? ] [ string-or-nil? ] bi* and
+ [ drop [ gadget-selection? ] [ drop t ] if ] [ 3drop f ] if ;
+
+: NSRect>rect ( NSRect world -- rect )
+ [ [ [ CGRect-x ] [ CGRect-y ] bi ] [ dim>> second ] bi* swap - 2array ]
+ [ drop [ CGRect-w ] [ CGRect-h ] bi 2array ]
+ 2bi <rect> ;
+
+: rect>NSRect ( rect world -- NSRect )
+ [ [ rect-loc first2 ] [ dim>> second ] bi* swap - ]
+ [ drop rect-dim first2 ]
+ 2bi <CGRect> ;
+
+CLASS: {
+ { +superclass+ "NSOpenGLView" }
+ { +name+ "FactorView" }
+ { +protocols+ { "NSTextInput" } }
+}
+
+! Rendering
+{ "drawRect:" "void" { "id" "SEL" "NSRect" }
+ [ 2drop window relayout-1 ]
+}
+
+! Events
+{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
+ [ 3drop 1 ]
+}
+
+{ "mouseEntered:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "mouseExited:" "void" { "id" "SEL" "id" }
+ [ 3drop forget-rollover ]
+}
+
+{ "mouseMoved:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "mouseDragged:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
+ [ nip send-mouse-moved ]
+}
+
+{ "mouseDown:" "void" { "id" "SEL" "id" }
+ [ nip send-button-down$ ]
+}
+
+{ "mouseUp:" "void" { "id" "SEL" "id" }
+ [ nip send-button-up$ ]
+}
+
+{ "rightMouseDown:" "void" { "id" "SEL" "id" }
+ [ nip send-button-down$ ]
+}
+
+{ "rightMouseUp:" "void" { "id" "SEL" "id" }
+ [ nip send-button-up$ ]
+}
+
+{ "otherMouseDown:" "void" { "id" "SEL" "id" }
+ [ nip send-button-down$ ]
+}
+
+{ "otherMouseUp:" "void" { "id" "SEL" "id" }
+ [ nip send-button-up$ ]
+}
+
+{ "scrollWheel:" "void" { "id" "SEL" "id" }
+ [ nip send-wheel$ ]
+}
+
+{ "keyDown:" "void" { "id" "SEL" "id" }
+ [ nip send-key-down-event ]
+}
+
+{ "keyUp:" "void" { "id" "SEL" "id" }
+ [ nip send-key-up-event ]
+}
+
+{ "undo:" "id" { "id" "SEL" "id" }
+ [ nip undo-action send-action$ ]
+}
+
+{ "redo:" "id" { "id" "SEL" "id" }
+ [ nip redo-action send-action$ ]
+}
+
+{ "cut:" "id" { "id" "SEL" "id" }
+ [ nip cut-action send-action$ ]
+}
+
+{ "copy:" "id" { "id" "SEL" "id" }
+ [ nip copy-action send-action$ ]
+}
+
+{ "paste:" "id" { "id" "SEL" "id" }
+ [ nip paste-action send-action$ ]
+}
+
+{ "delete:" "id" { "id" "SEL" "id" }
+ [ nip delete-action send-action$ ]
+}
+
+{ "selectAll:" "id" { "id" "SEL" "id" }
+ [ nip select-all-action send-action$ ]
+}
+
+! Multi-touch gestures: this is undocumented.
+! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
+{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaZ sgn {
+ { 1 [ zoom-in-action send-action$ ] }
+ { -1 [ zoom-out-action send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+}
+
+{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaX sgn {
+ { 1 [ left-action send-action$ ] }
+ { -1 [ right-action send-action$ ] }
+ { 0
+ [
+ dup -> deltaY sgn {
+ { 1 [ up-action send-action$ ] }
+ { -1 [ down-action send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+ }
+ } case
+ ]
+}
+
+! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
+
+{ "acceptsFirstResponder" "char" { "id" "SEL" }
+ [ 2drop 1 ]
+}
+
+! Services
+{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
+ [
+ ! We return either self or nil
+ [ over window-focus ] 2dip
+ valid-service? [ drop ] [ 2drop f ] if
+ ]
+}
+
+{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
+ [
+ CF>string-array NSStringPboardType swap member? [
+ [ drop window-focus gadget-selection ] dip over
+ [ set-pasteboard-string 1 ] [ 2drop 0 ] if
+ ] [ 3drop 0 ] if
+ ]
+}
+
+{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
+ [
+ pasteboard-string dup [
+ [ drop window ] dip swap user-input 1
+ ] [ 3drop 0 ] if
+ ]
+}
+
+! Text input
+{ "insertText:" "void" { "id" "SEL" "id" }
+ [ nip CF>string swap window user-input ]
+}
+
+{ "hasMarkedText" "char" { "id" "SEL" }
+ [ 2drop 0 ]
+}
+
+{ "markedRange" "NSRange" { "id" "SEL" }
+ [ 2drop 0 0 <NSRange> ]
+}
+
+{ "selectedRange" "NSRange" { "id" "SEL" }
+ [ 2drop 0 0 <NSRange> ]
+}
+
+{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
+ [ 2drop 2drop ]
+}
+
+{ "unmarkText" "void" { "id" "SEL" }
+ [ 2drop ]
+}
+
+{ "validAttributesForMarkedText" "id" { "id" "SEL" }
+ [ 2drop NSArray -> array ]
+}
+
+{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
+ [ 3drop f ]
+}
+
+{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
+ [ 3drop 0 ]
+}
+
+{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
+ [ 3drop 0 0 0 0 <CGRect> ]
+}
+
+{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
+ [ drop alien-address ]
+}
+
+! Initialization
+{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
+ [ 2drop dup view-dim swap window (>>dim) yield ]
+}
+
+{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
+ [ 3drop ]
+}
+
+{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
+ [
+ [ drop ] 2dip
+ SUPER-> initWithFrame:pixelFormat:
+ dup dup add-resize-observer
+ ]
+}
+
+{ "dealloc" "void" { "id" "SEL" }
+ [
+ drop
+ [ unregister-window ]
+ [ remove-observer ]
+ [ SUPER-> dealloc ]
+ tri
+ ]
+} ;
+
+: sync-refresh-to-screen ( GLView -- )
+ -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
+ CGLSetParameter drop ;
+
+: <FactorView> ( world -- view )
+ FactorView over rect-dim <GLView>
+ [ sync-refresh-to-screen ] keep
+ [ register-window ] keep ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorWindowDelegate" }
+}
+
+{ "windowDidMove:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object
+ [ -> contentView window ]
+ [ window-content-rect CGRect-x-y 2array ] bi
+ >>window-loc drop
+ ]
+}
+
+{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window focus-world
+ ]
+}
+
+{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
+ [
+ forget-rollover
+ 2nip -> object -> contentView window unfocus-world
+ ]
+}
+
+{ "windowShouldClose:" "char" { "id" "SEL" "id" }
+ [
+ 3drop 1
+ ]
+}
+
+{ "windowWillClose:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window ungraft
+ ]
+} ;
+
+: install-window-delegate ( window -- )
+ FactorWindowDelegate install-delegate ;
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2005, 2006 Doug Coleman.
+! Portions copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings arrays assocs ui
+ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
+ui.gestures ui.event-loop io kernel math
+math.vectors namespaces make sequences strings vectors words
+windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
+windows.messages windows.types windows.nt windows threads libc
+combinators fry combinators.short-circuit continuations
+command-line shuffle opengl ui.render ascii math.bitwise locals
+accessors math.geometry.rect math.order ascii calendar
+io.encodings.utf16n ;
+IN: ui.backend.windows
+
+SINGLETON: windows-ui-backend
+
+: crlf>lf ( str -- str' )
+ CHAR: \r swap remove ;
+
+: lf>crlf ( str -- str' )
+ [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
+
+: enum-clipboard ( -- seq )
+ 0
+ [ EnumClipboardFormats win32-error dup dup 0 > ]
+ [ ]
+ [ drop ]
+ produce nip ;
+
+: with-clipboard ( quot -- )
+ f OpenClipboard win32-error=0/f
+ call
+ CloseClipboard win32-error=0/f ; inline
+
+: paste ( -- str )
+ [
+ CF_UNICODETEXT IsClipboardFormatAvailable zero? [
+ ! nothing to paste
+ ""
+ ] [
+ CF_UNICODETEXT GetClipboardData dup win32-error=0/f
+ dup GlobalLock dup win32-error=0/f
+ GlobalUnlock win32-error=0/f
+ utf16n alien>string
+ ] if
+ ] with-clipboard
+ crlf>lf ;
+
+: copy ( str -- )
+ lf>crlf [
+ utf16n string>alien
+ EmptyClipboard win32-error=0/f
+ GMEM_MOVEABLE over length 1+ GlobalAlloc
+ dup win32-error=0/f
+
+ dup GlobalLock dup win32-error=0/f
+ swapd byte-array>memory
+ dup GlobalUnlock win32-error=0/f
+ CF_UNICODETEXT swap SetClipboardData win32-error=0/f
+ ] with-clipboard ;
+
+TUPLE: pasteboard ;
+C: <pasteboard> pasteboard
+
+M: pasteboard clipboard-contents drop paste ;
+M: pasteboard set-clipboard-contents drop copy ;
+
+: init-clipboard ( -- )
+ <pasteboard> clipboard set-global
+ <clipboard> selection set-global ;
+
+TUPLE: win-base hDC hRC ;
+TUPLE: win < win-base hWnd world title ;
+TUPLE: win-offscreen < win-base hBitmap bits ;
+C: <win> win
+C: <win-offscreen> win-offscreen
+
+SYMBOLS: msg-obj class-name-ptr mouse-captured ;
+
+: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
+: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
+
+: get-RECT-top-left ( RECT -- x y )
+ [ RECT-left ] keep RECT-top ;
+
+: get-RECT-dimensions ( RECT -- x y width height )
+ [ get-RECT-top-left ] keep
+ [ RECT-right ] keep [ RECT-left - ] keep
+ [ RECT-bottom ] keep RECT-top - ;
+
+: handle-wm-paint ( hWnd uMsg wParam lParam -- )
+ #! wParam and lParam are unused
+ #! only paint if width/height both > 0
+ 3drop window relayout-1 yield ;
+
+: handle-wm-size ( hWnd uMsg wParam lParam -- )
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
+
+: handle-wm-move ( hWnd uMsg wParam lParam -- )
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ swap window (>>window-loc) ;
+
+: wm-keydown-codes ( -- key )
+ H{
+ { 8 "BACKSPACE" }
+ { 9 "TAB" }
+ { 13 "RET" }
+ { 27 "ESC" }
+ { 33 "PAGE_UP" }
+ { 34 "PAGE_DOWN" }
+ { 35 "END" }
+ { 36 "HOME" }
+ { 37 "LEFT" }
+ { 38 "UP" }
+ { 39 "RIGHT" }
+ { 40 "DOWN" }
+ { 45 "INSERT" }
+ { 46 "DELETE" }
+ { 112 "F1" }
+ { 113 "F2" }
+ { 114 "F3" }
+ { 115 "F4" }
+ { 116 "F5" }
+ { 117 "F6" }
+ { 118 "F7" }
+ { 119 "F8" }
+ { 120 "F9" }
+ { 121 "F10" }
+ { 122 "F11" }
+ { 123 "F12" }
+ } ;
+
+: key-state-down? ( key -- ? )
+ GetKeyState 16 bit? ;
+
+: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
+: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
+: left-alt? ( -- ? ) VK_LMENU key-state-down? ;
+: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
+: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
+: right-alt? ( -- ? ) VK_RMENU key-state-down? ;
+: shift? ( -- ? ) left-shift? right-shift? or ;
+: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
+: alt? ( -- ? ) left-alt? right-alt? or ;
+: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
+
+: key-modifiers ( -- seq )
+ [
+ shift? [ S+ , ] when
+ ctrl? [ C+ , ] when
+ alt? [ A+ , ] when
+ ] { } make [ empty? not ] keep f ? ;
+
+: exclude-keys-wm-keydown
+ H{
+ { 16 "SHIFT" }
+ { 17 "CTRL" }
+ { 18 "ALT" }
+ { 20 "CAPS-LOCK" }
+ } ;
+
+: exclude-keys-wm-char
+ ! Values are ignored
+ H{
+ { 8 "BACKSPACE" }
+ { 9 "TAB" }
+ { 13 "RET" }
+ { 27 "ESC" }
+ } ;
+
+: exclude-key-wm-keydown? ( n -- ? )
+ exclude-keys-wm-keydown key? ;
+
+: exclude-key-wm-char? ( n -- ? )
+ exclude-keys-wm-char key? ;
+
+: keystroke>gesture ( n -- mods sym )
+ wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ;
+
+: send-key-gesture ( sym action? quot hWnd -- )
+ [ [ key-modifiers ] 3dip call ] dip
+ window propagate-key-gesture ; inline
+
+: send-key-down ( sym action? hWnd -- )
+ [ [ <key-down> ] ] dip send-key-gesture ;
+
+: send-key-up ( sym action? hWnd -- )
+ [ [ <key-up> ] ] dip send-key-gesture ;
+
+: key-sym ( wParam -- string/f action? )
+ {
+ {
+ [ dup LETTER? ]
+ [ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ]
+ }
+ { [ dup digit? ] [ 1string f ] }
+ [ wm-keydown-codes at t ]
+ } cond ;
+
+:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-keydown? [
+ wParam key-sym over [
+ dup ctrl? alt? xor or [
+ hWnd send-key-down
+ ] [ 2drop ] if
+ ] [ 2drop ] if
+ ] unless ;
+
+:: handle-wm-char ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-char? [
+ ctrl? alt? xor [
+ wParam 1string
+ [ f hWnd send-key-down ]
+ [ hWnd window user-input ] bi
+ ] unless
+ ] unless ;
+
+:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-keydown? [
+ wParam key-sym over [
+ hWnd send-key-up
+ ] [ 2drop ] if
+ ] unless ;
+
+:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ ? hwnd window (>>active?)
+ hwnd uMsg wParam lParam DefWindowProc ;
+
+: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
+ {
+ { [ over SC_MINIMIZE = ] [ f set-window-active ] }
+ { [ over SC_RESTORE = ] [ t set-window-active ] }
+ { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
+ { [ dup alpha? ] [ 4drop 0 ] }
+ { [ t ] [ DefWindowProc ] }
+ } cond ;
+
+: cleanup-window ( handle -- )
+ dup title>> [ free ] when*
+ dup hRC>> wglDeleteContext win32-error=0/f
+ dup hWnd>> swap hDC>> ReleaseDC win32-error=0/f ;
+
+M: windows-ui-backend (close-window)
+ dup hWnd>> unregister-window
+ dup cleanup-window
+ hWnd>> DestroyWindow win32-error=0/f ;
+
+: handle-wm-close ( hWnd uMsg wParam lParam -- )
+ 3drop window ungraft ;
+
+: handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
+ 3drop window [ focus-world ] when* ;
+
+: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
+ 3drop window [ unfocus-world ] when* ;
+
+: message>button ( uMsg -- button down? )
+ {
+ { WM_LBUTTONDOWN [ 1 t ] }
+ { WM_LBUTTONUP [ 1 f ] }
+ { WM_MBUTTONDOWN [ 2 t ] }
+ { WM_MBUTTONUP [ 2 f ] }
+ { WM_RBUTTONDOWN [ 3 t ] }
+ { WM_RBUTTONUP [ 3 f ] }
+
+ { WM_NCLBUTTONDOWN [ 1 t ] }
+ { WM_NCLBUTTONUP [ 1 f ] }
+ { WM_NCMBUTTONDOWN [ 2 t ] }
+ { WM_NCMBUTTONUP [ 2 f ] }
+ { WM_NCRBUTTONDOWN [ 3 t ] }
+ { WM_NCRBUTTONUP [ 3 f ] }
+ } case ;
+
+! If the user clicks in the window border ("non-client area")
+! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
+! mouse is subsequently released outside the NC area, we receive
+! a [LMR]BUTTONUP message and Factor can get confused. So we
+! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
+SYMBOL: nc-buttons
+
+: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
+ 2drop nip
+ message>button nc-buttons get
+ swap [ push ] [ delete ] if ;
+
+: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
+
+: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
+
+: mouse-event>gesture ( uMsg -- button )
+ key-modifiers swap message>button
+ [ <button-down> ] [ <button-up> ] if ;
+
+:: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
+ uMsg mouse-event>gesture
+ lParam >lo-hi
+ hWnd window ;
+
+: set-capture ( hwnd -- )
+ mouse-captured get [
+ drop
+ ] [
+ [ SetCapture drop ] keep
+ mouse-captured set
+ ] if ;
+
+: release-capture ( -- )
+ ReleaseCapture win32-error=0/f
+ mouse-captured off ;
+
+: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
+ [
+ over set-capture
+ dup message>button drop nc-buttons get delete
+ ] 2dip prepare-mouse send-button-down ;
+
+: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
+ mouse-captured get [ release-capture ] when
+ pick message>button drop dup nc-buttons get member? [
+ nc-buttons get delete 4drop
+ ] [
+ drop prepare-mouse send-button-up
+ ] if ;
+
+: make-TRACKMOUSEEVENT ( hWnd -- alien )
+ "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
+ "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
+
+: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
+ 2nip
+ over make-TRACKMOUSEEVENT
+ TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
+ 0 over set-TRACKMOUSEEVENT-dwHoverTime
+ TrackMouseEvent drop
+ >lo-hi swap window move-hand fire-motion ;
+
+:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
+ wParam mouse-wheel hand-loc get hWnd window send-wheel ;
+
+: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
+ #! message sent if windows needs application to stop dragging
+ 4drop release-capture ;
+
+: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
+ #! message sent if mouse leaves main application
+ 4drop forget-rollover ;
+
+SYMBOL: wm-handlers
+
+H{ } clone wm-handlers set-global
+
+: add-wm-handler ( quot wm -- )
+ dup array?
+ [ [ execute add-wm-handler ] with each ]
+ [ wm-handlers get-global set-at ] if ;
+
+[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
+[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
+
+[ handle-wm-size 0 ] WM_SIZE add-wm-handler
+[ handle-wm-move 0 ] WM_MOVE add-wm-handler
+
+[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
+[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler
+[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler
+
+[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler
+[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
+[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
+
+[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
+[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
+
+[ 4dup handle-wm-ncbutton DefWindowProc ]
+{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
+WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
+add-wm-handler
+
+[ nc-buttons get-global delete-all DefWindowProc ]
+{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
+
+[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler
+[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
+[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
+[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
+
+SYMBOL: trace-messages?
+
+! return 0 if you handle the message, else just let DefWindowProc return its val
+: ui-wndproc ( -- object )
+ "uint" { "void*" "uint" "long" "long" } "stdcall" [
+ pick
+ trace-messages? get-global [ dup windows-message-name name>> print flush ] when
+ wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
+ ] alien-callback ;
+
+: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
+
+M: windows-ui-backend do-events
+ msg-obj get-global
+ dup peek-message? [ drop ui-wait ] [
+ [ TranslateMessage drop ]
+ [ DispatchMessage drop ] bi
+ ] if ;
+
+: register-wndclassex ( -- class )
+ "WNDCLASSEX" <c-object>
+ f GetModuleHandle
+ class-name-ptr get-global
+ pick GetClassInfoEx zero? [
+ "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
+ { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
+ ui-wndproc over set-WNDCLASSEX-lpfnWndProc
+ 0 over set-WNDCLASSEX-cbClsExtra
+ 0 over set-WNDCLASSEX-cbWndExtra
+ f GetModuleHandle over set-WNDCLASSEX-hInstance
+ f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
+ over set-WNDCLASSEX-hIcon
+ f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
+
+ class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
+ RegisterClassEx dup win32-error=0/f
+ ] when ;
+
+: adjust-RECT ( RECT -- )
+ style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+
+: make-RECT ( world -- RECT )
+ [ window-loc>> dup ] [ rect-dim ] bi v+
+ "RECT" <c-object>
+ over first over set-RECT-right
+ swap second over set-RECT-bottom
+ over first over set-RECT-left
+ swap second over set-RECT-top ;
+
+: default-position-RECT ( RECT -- )
+ dup get-RECT-dimensions [ 2drop ] 2dip
+ CW_USEDEFAULT + pick set-RECT-bottom
+ CW_USEDEFAULT + over set-RECT-right
+ CW_USEDEFAULT over set-RECT-left
+ CW_USEDEFAULT swap set-RECT-top ;
+
+: make-adjusted-RECT ( rect -- RECT )
+ make-RECT
+ dup get-RECT-top-left [ zero? ] both? swap
+ dup adjust-RECT
+ swap [ dup default-position-RECT ] when ;
+
+: create-window ( rect -- hwnd )
+ make-adjusted-RECT
+ [ class-name-ptr get-global f ] dip
+ [
+ [ ex-style ] 2dip
+ { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
+ ] dip get-RECT-dimensions
+ f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
+
+: show-window ( hWnd -- )
+ dup SW_SHOW ShowWindow drop ! always succeeds
+ dup SetForegroundWindow drop
+ SetFocus drop ;
+
+: init-win32-ui ( -- )
+ V{ } clone nc-buttons set-global
+ "MSG" malloc-object msg-obj set-global
+ "Factor-window" utf16n malloc-string class-name-ptr set-global
+ register-wndclassex drop
+ GetDoubleClickTime milliseconds double-click-timeout set-global ;
+
+: cleanup-win32-ui ( -- )
+ class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
+ msg-obj get-global [ free ] when*
+ 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 ;
+
+M: windows-ui-backend (open-window) ( world -- )
+ [ create-window [ setup-gl ] keep ] keep
+ [ f <win> ] keep
+ [ swap hWnd>> register-window ] 2keep
+ dupd (>>handle)
+ hWnd>> show-window ;
+
+M: win-base select-gl-context ( handle -- )
+ [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
+ GdiFlush drop ;
+
+M: win-base flush-gl-context ( handle -- )
+ hDC>> SwapBuffers win32-error=0/f ;
+
+: (bitmap-info) ( dim -- BITMAPINFO )
+ "BITMAPINFO" <c-object> [
+ BITMAPINFO-bmiHeader {
+ [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
+ [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
+ [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
+ [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
+ [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
+ [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
+ [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
+ } 2cleave
+ ] keep ;
+
+: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
+ f CreateCompatibleDC
+ dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
+ [ f 0 CreateDIBSection ] keep *void*
+ [ 2dup SelectObject drop ] dip ;
+
+: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
+ make-offscreen-dc-and-bitmap [
+ [ dup offscreen-pfd-dwFlags setup-pixel-format ]
+ [ get-rc ] bi
+ ] 2dip ;
+
+M: windows-ui-backend (open-offscreen-buffer) ( world -- )
+ dup dim>> setup-offscreen-gl <win-offscreen>
+ >>handle drop ;
+
+M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
+ [ hDC>> DeleteDC drop ]
+ [ hBitmap>> DeleteObject drop ] bi ;
+
+! Windows 32-bit bitmaps don't actually use the alpha byte of
+! each pixel; it's left as zero
+
+: (make-opaque) ( byte-array -- byte-array' )
+ [ length 4 / ]
+ [ '[ 255 swap 4 * 3 + _ set-nth ] each ]
+ [ ] tri ;
+
+: (opaque-pixels) ( world -- pixels )
+ [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
+ memory>byte-array (make-opaque) ;
+
+M: windows-ui-backend offscreen-pixels ( world -- alien w h )
+ [ (opaque-pixels) ] [ dim>> first2 ] bi ;
+
+M: windows-ui-backend raise-window* ( world -- )
+ handle>> [ hWnd>> SetFocus drop ] when* ;
+
+M: windows-ui-backend set-title ( string world -- )
+ handle>>
+ dup title>> [ free ] when*
+ swap utf16n malloc-string
+ [ >>title ]
+ [ [ hWnd>> WM_SETTEXT 0 ] dip alien-address SendMessage drop ] bi ;
+
+M: windows-ui-backend (with-ui)
+ [
+ [
+ init-clipboard
+ init-win32-ui
+ start-ui
+ event-loop
+ ] [ cleanup-win32-ui ] [ ] cleanup
+ ] ui-running ;
+
+M: windows-ui-backend beep ( -- )
+ 0 MessageBeep drop ;
+
+windows-ui-backend ui-backend set-global
+
+[ "ui.tools" ] main-vocab-hook set-global
--- /dev/null
+Slava Pestov
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays ui ui.gadgets
+ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
+ui.event-loop assocs kernel math namespaces opengl
+sequences strings x11.xlib x11.events x11.xim x11.glx
+x11.clipboard x11.constants x11.windows io.encodings.string
+io.encodings.ascii io.encodings.utf8 combinators command-line
+math.vectors classes.tuple opengl.gl threads math.geometry.rect
+environment ascii ;
+IN: ui.backend.x11
+
+SINGLETON: x11-ui-backend
+
+: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
+
+TUPLE: x11-handle-base glx ;
+TUPLE: x11-handle < x11-handle-base xic window ;
+TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
+
+C: <x11-handle> x11-handle
+C: <x11-pixmap-handle> x11-pixmap-handle
+
+M: world expose-event nip relayout ;
+
+M: world configure-event
+ over configured-loc >>window-loc
+ swap configured-dim >>dim
+ ! In case dimensions didn't change
+ relayout-1 ;
+
+: modifiers
+ {
+ { S+ HEX: 1 }
+ { C+ HEX: 4 }
+ { A+ HEX: 8 }
+ } ;
+
+: key-codes
+ H{
+ { HEX: FF08 "BACKSPACE" }
+ { HEX: FF09 "TAB" }
+ { HEX: FF0D "RET" }
+ { HEX: FF8D "ENTER" }
+ { HEX: FF1B "ESC" }
+ { HEX: FFFF "DELETE" }
+ { HEX: FF50 "HOME" }
+ { HEX: FF51 "LEFT" }
+ { HEX: FF52 "UP" }
+ { HEX: FF53 "RIGHT" }
+ { HEX: FF54 "DOWN" }
+ { HEX: FF55 "PAGE_UP" }
+ { HEX: FF56 "PAGE_DOWN" }
+ { HEX: FF57 "END" }
+ { HEX: FF58 "BEGIN" }
+ { HEX: FFBE "F1" }
+ { HEX: FFBF "F2" }
+ { HEX: FFC0 "F3" }
+ { HEX: FFC1 "F4" }
+ { HEX: FFC2 "F5" }
+ { HEX: FFC3 "F6" }
+ { HEX: FFC4 "F7" }
+ { HEX: FFC5 "F8" }
+ { HEX: FFC6 "F9" }
+ } ;
+
+: key-code ( keysym -- keycode action? )
+ dup key-codes at [ t ] [ 1string f ] ?if ;
+
+: event-modifiers ( event -- seq )
+ XKeyEvent-state modifiers modifier ;
+
+: valid-input? ( string gesture -- ? )
+ over empty? [ 2drop f ] [
+ mods>> { f { S+ } } member? [
+ [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
+ ] [
+ [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
+ ] if
+ ] if ;
+
+: key-down-event>gesture ( event world -- string gesture )
+ dupd
+ handle>> xic>> lookup-string
+ [ swap event-modifiers ] dip key-code <key-down> ;
+
+M: world key-down-event
+ [ key-down-event>gesture ] keep
+ [ propagate-key-gesture drop ]
+ [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
+ 3bi ;
+
+: key-up-event>gesture ( event -- gesture )
+ dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
+
+M: world key-up-event
+ [ key-up-event>gesture ] dip propagate-key-gesture ;
+
+: mouse-event>gesture ( event -- modifiers button loc )
+ [ event-modifiers ]
+ [ XButtonEvent-button ]
+ [ mouse-event-loc ]
+ tri ;
+
+M: world button-down-event
+ [ mouse-event>gesture [ <button-down> ] dip ] dip
+ send-button-down ;
+
+M: world button-up-event
+ [ mouse-event>gesture [ <button-up> ] dip ] dip
+ send-button-up ;
+
+: mouse-event>scroll-direction ( event -- pair )
+ XButtonEvent-button {
+ { 4 { 0 -1 } }
+ { 5 { 0 1 } }
+ { 6 { -1 0 } }
+ { 7 { 1 0 } }
+ } at ;
+
+M: world wheel-event
+ [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
+ send-wheel ;
+
+M: world enter-event motion-event ;
+
+M: world leave-event 2drop forget-rollover ;
+
+M: world motion-event
+ [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
+ move-hand fire-motion ;
+
+M: world focus-in-event
+ nip
+ dup handle>> xic>> XSetICFocus focus-world ;
+
+M: world focus-out-event
+ nip
+ dup handle>> xic>> XUnsetICFocus unfocus-world ;
+
+M: world selection-notify-event
+ [ handle>> window>> selection-from-event ] keep
+ user-input ;
+
+: supported-type? ( atom -- ? )
+ { "UTF8_STRING" "STRING" "TEXT" }
+ [ x-atom = ] with any? ;
+
+: clipboard-for-atom ( atom -- clipboard )
+ {
+ { XA_PRIMARY [ selection get ] }
+ { XA_CLIPBOARD [ clipboard get ] }
+ [ drop <clipboard> ]
+ } case ;
+
+: encode-clipboard ( string type -- bytes )
+ XSelectionRequestEvent-target
+ XA_UTF8_STRING = utf8 ascii ? encode ;
+
+: set-selection-prop ( evt -- )
+ dpy get swap
+ [ XSelectionRequestEvent-requestor ] keep
+ [ XSelectionRequestEvent-property ] keep
+ [ XSelectionRequestEvent-target ] keep
+ [ 8 PropModeReplace ] dip
+ [
+ XSelectionRequestEvent-selection
+ clipboard-for-atom contents>>
+ ] keep encode-clipboard dup length XChangeProperty drop ;
+
+M: world selection-request-event
+ drop dup XSelectionRequestEvent-target {
+ { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
+ { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
+ { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
+ [ drop send-notify-failure ]
+ } cond ;
+
+M: x11-ui-backend (close-window) ( handle -- )
+ [ xic>> XDestroyIC ]
+ [ glx>> destroy-glx ]
+ [ window>> [ unregister-window ] [ destroy-window ] bi ]
+ tri ;
+
+M: world client-event
+ swap close-box? [ ungraft ] [ drop ] if ;
+
+: gadget-window ( world -- )
+ [ [ window-loc>> ] [ dim>> ] bi glx-window ]
+ [ "Factor" create-xic ]
+ [ ] tri <x11-handle>
+ [ window>> register-window ] [ >>handle drop ] 2bi ;
+
+: wait-event ( -- event )
+ QueuedAfterFlush events-queued 0 > [
+ next-event dup
+ None XFilterEvent 0 = [ drop wait-event ] unless
+ ] [ ui-wait wait-event ] if ;
+
+M: x11-ui-backend do-events
+ wait-event dup XAnyEvent-window window dup
+ [ handle-event ] [ 2drop ] if ;
+
+: x-clipboard@ ( gadget clipboard -- prop win )
+ atom>> swap
+ find-world handle>> window>> ;
+
+M: x-clipboard copy-clipboard
+ [ x-clipboard@ own-selection ] keep
+ (>>contents) ;
+
+M: x-clipboard paste-clipboard
+ [ find-world handle>> window>> ] dip atom>> convert-selection ;
+
+: init-clipboard ( -- )
+ XA_PRIMARY <x-clipboard> selection set-global
+ XA_CLIPBOARD <x-clipboard> clipboard set-global ;
+
+: set-title-old ( dpy window string -- )
+ dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
+
+: set-title-new ( dpy window string -- )
+ [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
+ utf8 encode dup length XChangeProperty drop ;
+
+M: x11-ui-backend set-title ( string world -- )
+ handle>> window>> swap
+ [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
+
+M: x11-ui-backend set-fullscreen* ( ? world -- )
+ handle>> window>> "XClientMessageEvent" <c-object>
+ [ set-XClientMessageEvent-window ] keep
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
+ over set-XClientMessageEvent-data0
+ ClientMessage over set-XClientMessageEvent-type
+ dpy get over set-XClientMessageEvent-display
+ "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
+ 32 over set-XClientMessageEvent-format
+ "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
+ [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
+
+M: x11-ui-backend (open-window) ( world -- )
+ dup gadget-window
+ handle>> window>> dup set-closable map-window ;
+
+M: x11-ui-backend raise-window* ( world -- )
+ handle>> [
+ dpy get swap window>> XRaiseWindow drop
+ ] when* ;
+
+M: x11-handle select-gl-context ( handle -- )
+ dpy get swap
+ [ window>> ] [ glx>> ] bi glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-handle flush-gl-context ( handle -- )
+ dpy get swap window>> glXSwapBuffers ;
+
+M: x11-pixmap-handle select-gl-context ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-pixmap-handle flush-gl-context ( handle -- )
+ drop ;
+
+M: x11-ui-backend (open-offscreen-buffer) ( world -- )
+ dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
+M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
+ dpy get swap
+ [ glx-pixmap>> glXDestroyGLXPixmap ]
+ [ pixmap>> XFreePixmap drop ]
+ [ glx>> glXDestroyContext ] 2tri ;
+
+M: x11-ui-backend offscreen-pixels ( world -- alien w h )
+ [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
+
+M: x11-ui-backend (with-ui) ( quot -- )
+ [
+ f [
+ [
+ init-clipboard
+ start-ui
+ event-loop
+ ] with-xim
+ ] with-x
+ ] ui-running ;
+
+M: x11-ui-backend beep ( -- )
+ dpy get 100 XBell drop ;
+
+x11-ui-backend ui-backend set-global
+
+[ "DISPLAY" os-env "ui.tools" "listener" ? ]
+main-vocab-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2008 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
-cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
-cocoa.windows cocoa.classes cocoa.nibs sequences system ui
-ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.cocoa.views core-foundation core-foundation.run-loop threads
-math.geometry.rect fry libc generalizations alien.c-types
-cocoa.views combinators io.thread ;
-IN: ui.cocoa
-
-TUPLE: handle ;
-TUPLE: window-handle < handle view window ;
-TUPLE: offscreen-handle < handle context buffer ;
-
-C: <window-handle> window-handle
-C: <offscreen-handle> offscreen-handle
-
-SINGLETON: cocoa-ui-backend
-
-TUPLE: pasteboard handle ;
-
-C: <pasteboard> pasteboard
-
-M: pasteboard clipboard-contents
- handle>> pasteboard-string ;
-
-M: pasteboard set-clipboard-contents
- handle>> set-pasteboard-string ;
-
-: init-clipboard ( -- )
- NSPasteboard -> generalPasteboard <pasteboard>
- clipboard set-global
- <clipboard> selection set-global ;
-
-: world>NSRect ( world -- NSRect )
- [ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ <NSRect> ;
-
-: gadget-window ( world -- )
- dup <FactorView>
- 2dup swap world>NSRect <ViewWindow>
- [ [ -> release ] [ install-window-delegate ] bi* ]
- [ <window-handle> ] 2bi
- >>handle drop ;
-
-M: cocoa-ui-backend set-title ( string world -- )
- handle>> window>> swap <NSString> -> setTitle: ;
-
-: enter-fullscreen ( world -- )
- handle>> view>>
- NSScreen -> mainScreen
- f -> enterFullScreenMode:withOptions:
- drop ;
-
-: exit-fullscreen ( world -- )
- handle>> view>> f -> exitFullScreenModeWithOptions: ;
-
-M: cocoa-ui-backend set-fullscreen* ( ? world -- )
- swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
-
-M: cocoa-ui-backend fullscreen* ( world -- ? )
- handle>> view>> -> isInFullScreenMode zero? not ;
-
-: auto-position ( world -- )
- dup window-loc>> { 0 0 } = [
- handle>> window>> -> center
- ] [
- drop
- ] if ;
-
-M: cocoa-ui-backend (open-window) ( world -- )
- dup gadget-window
- dup auto-position
- handle>> window>> f -> makeKeyAndOrderFront: ;
-
-M: cocoa-ui-backend (close-window) ( handle -- )
- window>> -> release ;
-
-M: cocoa-ui-backend close-window ( gadget -- )
- find-world [
- handle>> [
- window>> f -> performClose:
- ] when*
- ] when* ;
-
-M: cocoa-ui-backend raise-window* ( world -- )
- handle>> [
- window>> dup f -> orderFront: -> makeKeyWindow
- NSApp 1 -> activateIgnoringOtherApps:
- ] when* ;
-
-: pixel-size ( pixel-format -- size )
- 0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
- keep *int -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 <PixelFormat>
- [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
- [ offscreen-buffer ] 2bi
- 4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
-
-M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
- dup gadget-offscreen-context <offscreen-handle> >>handle drop ;
-
-M: cocoa-ui-backend (close-offscreen-buffer) ( handle -- )
- [ context>> -> release ]
- [ buffer>> free ] bi ;
-
-GENERIC: (gl-context) ( handle -- context )
-M: window-handle (gl-context) view>> -> openGLContext ;
-M: offscreen-handle (gl-context) context>> ;
-
-M: handle select-gl-context ( handle -- )
- (gl-context) -> makeCurrentContext ;
-
-M: handle flush-gl-context ( handle -- )
- (gl-context) -> flushBuffer ;
-
-M: cocoa-ui-backend offscreen-pixels ( world -- alien w h )
- [ handle>> buffer>> ] [ dim>> first2 neg ] bi ;
-
-M: cocoa-ui-backend beep ( -- )
- NSBeep ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorApplicationDelegate" }
-}
-
-{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
- [ 3drop reset-run-loop ]
-} ;
-
-: install-app-delegate ( -- )
- NSApp FactorApplicationDelegate install-delegate ;
-
-SYMBOL: cocoa-init-hook
-
-cocoa-init-hook global [
- [ "MiniFactor.nib" load-nib install-app-delegate ] or
-] change-at
-
-M: cocoa-ui-backend ui
- "UI" assert.app [
- [
- init-clipboard
- cocoa-init-hook get call
- start-ui
- f io-thread-running? set-global
- init-thread-timer
- reset-run-loop
- NSApp -> run
- ] ui-running
- ] with-cocoa ;
-
-cocoa-ui-backend ui-backend set-global
-
-[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
+++ /dev/null
-Cocoa UI backend
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Cocoa integration for UI developer tools
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax cocoa cocoa.nibs cocoa.application
-cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
-core-foundation core-foundation.strings help.topics kernel
-memory namespaces parser system ui ui.tools.browser
-ui.tools.listener ui.tools.workspace ui.cocoa eval locals ;
-IN: ui.cocoa.tools
-
-: finder-run-files ( alien -- )
- CF>string-array listener-run-files
- NSApp NSApplicationDelegateReplySuccess
- -> replyToOpenOrPrint: ;
-
-: menu-run-files ( -- )
- open-panel [ listener-run-files ] when* ;
-
-: menu-save-image ( -- )
- image save-panel [ save-image ] when* ;
-
-! Handle Open events from the Finder
-CLASS: {
- { +superclass+ "FactorApplicationDelegate" }
- { +name+ "FactorWorkspaceApplicationDelegate" }
-}
-
-{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
- [ [ 3drop ] dip finder-run-files ]
-}
-
-{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }
- [ 3drop workspace-window f ]
-}
-
-{ "runFactorFile:" "id" { "id" "SEL" "id" }
- [ 3drop menu-run-files f ]
-}
-
-{ "saveFactorImage:" "id" { "id" "SEL" "id" }
- [ 3drop save f ]
-}
-
-{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
- [ 3drop menu-save-image f ]
-}
-
-{ "showFactorHelp:" "id" { "id" "SEL" "id" }
- [ 3drop "handbook" com-follow f ]
-} ;
-
-: install-app-delegate ( -- )
- NSApp FactorWorkspaceApplicationDelegate install-delegate ;
-
-! Service support; evaluate Factor code from other apps
-:: do-service ( pboard error quot -- )
- pboard error ?pasteboard-string
- dup [ quot call ] when
- [ pboard set-pasteboard-string ] when* ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorServiceProvider" }
-} {
- "evalInListener:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "void*" }
- [ nip [ eval-listener f ] do-service 2drop ]
-} {
- "evalToString:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "void*" }
- [ nip [ eval>string ] do-service 2drop ]
-} ;
-
-: register-services ( -- )
- NSApp
- FactorServiceProvider -> alloc -> init
- -> setServicesProvider: ;
-
-FUNCTION: void NSUpdateDynamicServices ;
-
-[
- install-app-delegate
- "Factor.nib" load-nib
- register-services
-] cocoa-init-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Cocoa NSView implementation displaying Factor gadgets
+++ /dev/null
-unportable
+++ /dev/null
-IN: ui.cocoa.views.tests
-USING: ui.cocoa.views tools.test kernel math.geometry.rect
-namespaces ;
-
-[ t ] [
- T{ rect
- { loc { 0 0 } }
- { dim { 1000 1000 } }
- } "world" set
-
- T{ rect
- { loc { 1.5 2.25 } }
- { dim { 13.0 14.0 } }
- } dup "world" get rect>NSRect "world" get NSRect>rect =
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays assocs cocoa kernel
-math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
-cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
-sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
-core-foundation.strings threads combinators math.geometry.rect ;
-IN: ui.cocoa.views
-
-: send-mouse-moved ( view event -- )
- [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
-
-: button ( event -- n )
- #! Cocoa -> Factor UI button mapping
- -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
-
-: modifiers
- {
- { S+ HEX: 20000 }
- { C+ HEX: 40000 }
- { A+ HEX: 100000 }
- { M+ HEX: 80000 }
- } ;
-
-: key-codes
- H{
- { 71 "CLEAR" }
- { 36 "RET" }
- { 76 "ENTER" }
- { 53 "ESC" }
- { 48 "TAB" }
- { 51 "BACKSPACE" }
- { 115 "HOME" }
- { 117 "DELETE" }
- { 119 "END" }
- { 122 "F1" }
- { 120 "F2" }
- { 99 "F3" }
- { 118 "F4" }
- { 96 "F5" }
- { 97 "F6" }
- { 98 "F7" }
- { 100 "F8" }
- { 123 "LEFT" }
- { 124 "RIGHT" }
- { 125 "DOWN" }
- { 126 "UP" }
- { 116 "PAGE_UP" }
- { 121 "PAGE_DOWN" }
- } ;
-
-: key-code ( event -- string ? )
- dup -> keyCode key-codes at
- [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if ;
-
-: event-modifiers ( event -- modifiers )
- -> modifierFlags modifiers modifier ;
-
-: key-event>gesture ( event -- modifiers keycode action? )
- dup event-modifiers swap key-code ;
-
-: send-key-event ( view gesture -- )
- swap window propagate-key-gesture ;
-
-: interpret-key-event ( view event -- )
- NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
-
-: send-key-down-event ( view event -- )
- [ key-event>gesture <key-down> send-key-event ]
- [ interpret-key-event ]
- 2bi ;
-
-: send-key-up-event ( view event -- )
- key-event>gesture <key-up> send-key-event ;
-
-: mouse-event>gesture ( event -- modifiers button )
- dup event-modifiers swap button ;
-
-: send-button-down$ ( view event -- )
- [ nip mouse-event>gesture <button-down> ]
- [ mouse-location ]
- [ drop window ]
- 2tri send-button-down ;
-
-: send-button-up$ ( view event -- )
- [ nip mouse-event>gesture <button-up> ]
- [ mouse-location ]
- [ drop window ]
- 2tri send-button-up ;
-
-: send-wheel$ ( view event -- )
- [ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ]
- [ mouse-location ]
- [ drop window ]
- 2tri send-wheel ;
-
-: send-action$ ( view event gesture -- junk )
- [ drop window ] dip send-action f ;
-
-: add-resize-observer ( observer object -- )
- [
- "updateFactorGadgetSize:"
- "NSViewFrameDidChangeNotification" <NSString>
- ] dip add-observer ;
-
-: string-or-nil? ( NSString -- ? )
- [ CF>string NSStringPboardType = ] [ t ] if* ;
-
-: valid-service? ( gadget send-type return-type -- ? )
- over string-or-nil? over string-or-nil? and
- [ drop [ gadget-selection? ] [ drop t ] if ] [ 3drop f ] if ;
-
-: NSRect>rect ( NSRect world -- rect )
- [ [ [ NSRect-x ] [ NSRect-y ] bi ] [ dim>> second ] bi* swap - 2array ]
- [ drop [ NSRect-w ] [ NSRect-h ] bi 2array ]
- 2bi <rect> ;
-
-: rect>NSRect ( rect world -- NSRect )
- [ [ rect-loc first2 ] [ dim>> second ] bi* swap - ]
- [ drop rect-dim first2 ]
- 2bi <NSRect> ;
-
-CLASS: {
- { +superclass+ "NSOpenGLView" }
- { +name+ "FactorView" }
- { +protocols+ { "NSTextInput" } }
-}
-
-! Rendering
-{ "drawRect:" "void" { "id" "SEL" "NSRect" }
- [ 2drop window relayout-1 ]
-}
-
-! Events
-{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
- [ 3drop 1 ]
-}
-
-{ "mouseEntered:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "mouseExited:" "void" { "id" "SEL" "id" }
- [ 3drop forget-rollover ]
-}
-
-{ "mouseMoved:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "mouseDragged:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
- [ nip send-mouse-moved ]
-}
-
-{ "mouseDown:" "void" { "id" "SEL" "id" }
- [ nip send-button-down$ ]
-}
-
-{ "mouseUp:" "void" { "id" "SEL" "id" }
- [ nip send-button-up$ ]
-}
-
-{ "rightMouseDown:" "void" { "id" "SEL" "id" }
- [ nip send-button-down$ ]
-}
-
-{ "rightMouseUp:" "void" { "id" "SEL" "id" }
- [ nip send-button-up$ ]
-}
-
-{ "otherMouseDown:" "void" { "id" "SEL" "id" }
- [ nip send-button-down$ ]
-}
-
-{ "otherMouseUp:" "void" { "id" "SEL" "id" }
- [ nip send-button-up$ ]
-}
-
-{ "scrollWheel:" "void" { "id" "SEL" "id" }
- [ nip send-wheel$ ]
-}
-
-{ "keyDown:" "void" { "id" "SEL" "id" }
- [ nip send-key-down-event ]
-}
-
-{ "keyUp:" "void" { "id" "SEL" "id" }
- [ nip send-key-up-event ]
-}
-
-{ "cut:" "id" { "id" "SEL" "id" }
- [ nip T{ cut-action } send-action$ ]
-}
-
-{ "copy:" "id" { "id" "SEL" "id" }
- [ nip T{ copy-action } send-action$ ]
-}
-
-{ "paste:" "id" { "id" "SEL" "id" }
- [ nip T{ paste-action } send-action$ ]
-}
-
-{ "delete:" "id" { "id" "SEL" "id" }
- [ nip T{ delete-action } send-action$ ]
-}
-
-{ "selectAll:" "id" { "id" "SEL" "id" }
- [ nip T{ select-all-action } send-action$ ]
-}
-
-! Multi-touch gestures: this is undocumented.
-! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
-{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
- [
- nip
- dup -> deltaZ sgn {
- { 1 [ T{ zoom-in-action } send-action$ ] }
- { -1 [ T{ zoom-out-action } send-action$ ] }
- { 0 [ 2drop ] }
- } case
- ]
-}
-
-{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
- [
- nip
- dup -> deltaX sgn {
- { 1 [ T{ left-action } send-action$ ] }
- { -1 [ T{ right-action } send-action$ ] }
- { 0
- [
- dup -> deltaY sgn {
- { 1 [ T{ up-action } send-action$ ] }
- { -1 [ T{ down-action } send-action$ ] }
- { 0 [ 2drop ] }
- } case
- ]
- }
- } case
- ]
-}
-
-! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
-
-{ "acceptsFirstResponder" "char" { "id" "SEL" }
- [ 2drop 1 ]
-}
-
-! Services
-{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
- [
- ! We return either self or nil
- [ over window-focus ] 2dip
- valid-service? [ drop ] [ 2drop f ] if
- ]
-}
-
-{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
- [
- CF>string-array NSStringPboardType swap member? [
- [ drop window-focus gadget-selection ] dip over
- [ set-pasteboard-string 1 ] [ 2drop 0 ] if
- ] [ 3drop 0 ] if
- ]
-}
-
-{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
- [
- pasteboard-string dup [
- [ drop window ] dip swap user-input 1
- ] [ 3drop 0 ] if
- ]
-}
-
-! Text input
-{ "insertText:" "void" { "id" "SEL" "id" }
- [ nip CF>string swap window user-input ]
-}
-
-{ "hasMarkedText" "char" { "id" "SEL" }
- [ 2drop 0 ]
-}
-
-{ "markedRange" "NSRange" { "id" "SEL" }
- [ 2drop 0 0 <NSRange> ]
-}
-
-{ "selectedRange" "NSRange" { "id" "SEL" }
- [ 2drop 0 0 <NSRange> ]
-}
-
-{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
- [ 2drop 2drop ]
-}
-
-{ "unmarkText" "void" { "id" "SEL" }
- [ 2drop ]
-}
-
-{ "validAttributesForMarkedText" "id" { "id" "SEL" }
- [ 2drop NSArray -> array ]
-}
-
-{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
- [ 3drop f ]
-}
-
-{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
- [ 3drop 0 ]
-}
-
-{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
- [ 3drop 0 0 0 0 <NSRect> ]
-}
-
-{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
- [ drop alien-address ]
-}
-
-! Initialization
-{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
- [ 2drop dup view-dim swap window (>>dim) yield ]
-}
-
-{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
- [ 3drop ]
-}
-
-{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
- [
- [ drop ] 2dip
- SUPER-> initWithFrame:pixelFormat:
- dup dup add-resize-observer
- ]
-}
-
-{ "dealloc" "void" { "id" "SEL" }
- [
- drop
- [ unregister-window ]
- [ remove-observer ]
- [ SUPER-> dealloc ]
- tri
- ]
-} ;
-
-: sync-refresh-to-screen ( GLView -- )
- -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
- CGLSetParameter drop ;
-
-: <FactorView> ( world -- view )
- FactorView over rect-dim <GLView>
- [ sync-refresh-to-screen ] keep
- [ register-window ] keep ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorWindowDelegate" }
-}
-
-{ "windowDidMove:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object
- dup window-content-rect NSRect-x-y 2array
- swap -> contentView window (>>window-loc)
- ]
-}
-
-{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object -> contentView window focus-world
- ]
-}
-
-{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
- [
- forget-rollover
- 2nip -> object -> contentView window unfocus-world
- ]
-}
-
-{ "windowShouldClose:" "char" { "id" "SEL" "id" }
- [
- 3drop 1
- ]
-}
-
-{ "windowWillClose:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object -> contentView window ungraft
- ]
-} ;
-
-: install-window-delegate ( window -- )
- FactorWindowDelegate install-delegate ;
IN: ui.commands.tests
USING: ui.commands ui.gestures tools.test help.markup io
-io.streams.string ;
+io.streams.string system kernel ;
-[ "A+a" ] [ T{ key-down f { A+ } "a" } gesture>string ] unit-test
-[ "b" ] [ T{ key-down f f "b" } gesture>string ] unit-test
[ "Press Button 2" ] [ T{ button-down f f 2 } gesture>string ] unit-test
-: com-test-1 ;
+: com-test-1 ( -- ) ;
\ com-test-1 H{ } define-command
[ [ 3 com-test-1 ] ] [ 3 \ com-test-1 command-quot ] unit-test
-: com-test-2 ;
+: com-test-2 ( -- ) ;
\ com-test-2 H{ { +nullary+ t } } define-command
{ T{ key-down f { C+ } "x" } com-test-1 }
} define-command-map
-[ "C+x" ] [
- [
- { $command testing "testing" com-test-1 } print-element
- ] with-string-writer
-] unit-test
+os macosx? [
+ [ "⌘A" ] [ T{ key-down f { A+ } "a" } gesture>string ] unit-test
+ [ "B" ] [ T{ key-down f f "b" } gesture>string ] unit-test
+
+ [ "⌃X" ] [
+ [
+ { $command testing "testing" com-test-1 } print-element
+ ] with-string-writer
+ ] unit-test
+] [
+ [ "A+a" ] [ T{ key-down f { A+ } "a" } gesture>string ] unit-test
+ [ "b" ] [ T{ key-down f f "b" } gesture>string ] unit-test
+
+ [ "C+x" ] [
+ [
+ { $command testing "testing" com-test-1 } print-element
+ ] with-string-writer
+ ] unit-test
+] if
+
+: com-foo. ( -- ) ;
+
+[ "Foo" ] [ \ com-foo. command-name ] unit-test
\ No newline at end of file
M: word command-name ( word -- str )
name>>
- "com-" ?head drop
+ "com-" ?head drop "." ?tail drop
dup first Letter? [ rest ] unless
(command-name) ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.syntax help.markup strings kernel alien opengl
-quotations ui.render io.styles freetype ;
-IN: ui.freetype
-
-HELP: freetype
-{ $values { "alien" alien } }
-{ $description "Outputs a native handle used by the FreeType library, initializing FreeType first if necessary." } ;
-
-HELP: open-fonts
-{ $var-description "Global variable. Hashtable mapping font descriptors to " { $link font } " instances." } ;
-
-{ font open-fonts open-font char-width string-width text-dim draw-string draw-text } related-words
-
-HELP: init-freetype
-{ $description "Initializes the FreeType library." }
-{ $notes "Do not call this word if you are using the UI." } ;
-
-HELP: font
-
-{ $class-description
-
-"A font which has been loaded by FreeType. Font instances have the following slots:"
-
-{
- $list
- {
- { $snippet "ascent" } ", "
- { $snippet "descent" } ", "
- { $snippet "height" } " - metrics."
- }
-
- {
- { $snippet "handle" }
- " - alien pointer to an "
- { $snippet "FT_Face" } "."
- }
-
- {
- { $snippet "widths" }
- " - sequence of character widths. Use "
- { $snippet "width" }
- " and "
- { $snippet "width" }
- " to compute string widths instead of reading this sequence directly."
- }
-}
-
-} ;
-
-HELP: close-freetype
-{ $description "Closes the FreeType library." }
-{ $notes "Do not call this word if you are using the UI." } ;
-
-HELP: open-face
-{ $values { "font" string } { "style" "one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
-{ $description "Loads a TrueType font with the requested logical font name and style." }
-{ $notes "This is a low-level word. Call " { $link open-font } " instead." } ;
-
-HELP: render-glyph
-{ $values { "font" font } { "char" "a non-negative integer" } { "bitmap" alien } }
-{ $description "Renders a character and outputs a pointer to the bitmap." } ;
-
-HELP: <char-sprite>
-{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
-{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
-
-HELP: (draw-string)
-{ $values { "open-font" font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
-{ $description "Draws a line of text." }
-{ $notes "This is a low-level word, UI code should use " { $link draw-string } " or " { $link draw-text } " instead." }
-{ $side-effects "sprites" } ;
-
-HELP: run-char-widths
-{ $values { "open-font" font } { "string" string } { "widths" "a sequence of integers" } }
-{ $description "Outputs a sequence of x co-ordinates of the midpoint of each character in the string." }
-{ $notes "This word is used to convert x offsets to document locations, for example when the user moves the caret by clicking the mouse." } ;
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors alien.c-types arrays io kernel libc
-math math.vectors namespaces opengl opengl.gl assocs
-sequences io.files io.styles continuations freetype
-ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
-locals specialized-arrays.direct.uchar ;
-IN: ui.freetype
-
-TUPLE: freetype-renderer ;
-
-SYMBOL: open-fonts
-
-: freetype-error ( n -- )
- zero? [ "FreeType error" throw ] unless ;
-
-DEFER: freetype
-
-: init-freetype ( -- )
- global [
- f <void*> dup FT_Init_FreeType freetype-error
- *void* \ freetype set
- H{ } clone open-fonts set
- ] bind ;
-
-: freetype ( -- alien )
- \ freetype get-global expired? [ init-freetype ] when
- \ freetype get-global ;
-
-TUPLE: font < identity-tuple
-ascent descent height handle widths ;
-
-M: font hashcode* drop font hashcode* ;
-
-: close-font ( font -- ) handle>> FT_Done_Face ;
-
-: close-freetype ( -- )
- global [
- open-fonts [ [ drop close-font ] assoc-each f ] change
- freetype [ FT_Done_FreeType f ] change
- ] bind ;
-
-M: freetype-renderer free-fonts ( world -- )
- [ handle>> select-gl-context ]
- [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
-
-: ttf-name ( font style -- name )
- 2array H{
- { { "monospace" plain } "VeraMono" }
- { { "monospace" bold } "VeraMoBd" }
- { { "monospace" bold-italic } "VeraMoBI" }
- { { "monospace" italic } "VeraMoIt" }
- { { "sans-serif" plain } "Vera" }
- { { "sans-serif" bold } "VeraBd" }
- { { "sans-serif" bold-italic } "VeraBI" }
- { { "sans-serif" italic } "VeraIt" }
- { { "serif" plain } "VeraSe" }
- { { "serif" bold } "VeraSeBd" }
- { { "serif" bold-italic } "VeraBI" }
- { { "serif" italic } "VeraIt" }
- } at ;
-
-: ttf-path ( name -- string )
- "resource:fonts/" ".ttf" surround ;
-
-: (open-face) ( path length -- face )
- #! We use FT_New_Memory_Face, not FT_New_Face, since
- #! FT_New_Face only takes an ASCII path name and causes
- #! problems on localized versions of Windows
- [ freetype ] 2dip 0 f <void*> [
- FT_New_Memory_Face freetype-error
- ] keep *void* ;
-
-: open-face ( font style -- face )
- ttf-name ttf-path malloc-file-contents (open-face) ;
-
-SYMBOL: dpi
-
-72 dpi set-global
-
-: ft-floor ( m -- n ) -6 shift ; inline
-
-: ft-ceil ( m -- n ) 63 + -64 bitand -6 shift ; inline
-
-: font-units>pixels ( n font -- n )
- face-size face-size-y-scale FT_MulFix ;
-
-: init-ascent ( font face -- font )
- dup face-y-max swap font-units>pixels >>ascent ; inline
-
-: init-descent ( font face -- font )
- dup face-y-min swap font-units>pixels >>descent ; inline
-
-: init-font ( font -- font )
- dup handle>> init-ascent
- dup handle>> init-descent
- dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
-
-: set-char-size ( open-font size -- open-font )
- [ dup handle>> 0 ] dip
- 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
-
-: <font> ( font -- open-font )
- font new
- H{ } clone >>widths
- over first2 open-face >>handle
- swap third set-char-size
- init-font ;
-
-M: freetype-renderer open-font ( font -- open-font )
- freetype drop open-fonts get [ <font> ] cache ;
-
-: load-glyph ( font char -- glyph )
- [ handle>> dup ] dip 0 FT_Load_Char
- freetype-error face-glyph ;
-
-: char-width ( open-font char -- w )
- over widths>> [
- dupd load-glyph glyph-hori-advance ft-ceil
- ] cache nip ;
-
-M: freetype-renderer string-width ( open-font string -- w )
- [ 0 ] 2dip [ char-width + ] with each ;
-
-M: freetype-renderer string-height ( open-font string -- h )
- drop height>> ;
-
-: glyph-size ( glyph -- dim )
- dup glyph-hori-advance ft-ceil
- swap glyph-height ft-ceil 2array ;
-
-: render-glyph ( font char -- bitmap )
- load-glyph dup
- FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
-
-:: copy-pixel ( i j bitmap texture -- i j )
- 255 j texture set-nth
- i bitmap nth j 1 + texture set-nth
- i 1 + j 2 + ; inline
-
-:: (copy-row) ( i j bitmap texture end -- )
- i end < [
- i j bitmap texture copy-pixel
- bitmap texture end (copy-row)
- ] when ; inline recursive
-
-:: copy-row ( i j bitmap texture width width2 -- i j )
- i j bitmap texture i width + (copy-row)
- i width +
- j width2 + ; inline
-
-:: copy-bitmap ( glyph texture -- )
- [let* | bitmap [ glyph glyph-bitmap-buffer ]
- rows [ glyph glyph-bitmap-rows ]
- width [ glyph glyph-bitmap-width ]
- width2 [ width next-power-of-2 2 * ] |
- bitmap [
- [let | bitmap' [ bitmap rows width * <direct-uchar-array> ] |
- 0 0
- rows [ bitmap' texture width width2 copy-row ] times
- 2drop
- ]
- ] when
- ] ;
-
-: bitmap>texture ( glyph sprite -- id )
- tuck sprite-size2 * 2 * <byte-array>
- [ copy-bitmap ] keep gray-texture ;
-
-: glyph-texture-loc ( glyph font -- loc )
- [ drop glyph-hori-bearing-x ft-floor ]
- [ ascent>> swap glyph-hori-bearing-y - ft-floor ]
- 2bi 2array ;
-
-: glyph-texture-size ( glyph -- dim )
- [ glyph-bitmap-width next-power-of-2 ]
- [ glyph-bitmap-rows next-power-of-2 ]
- bi 2array ;
-
-: <char-sprite> ( open-font char -- sprite )
- over [ render-glyph dup ] dip glyph-texture-loc
- over glyph-size pick glyph-texture-size <sprite>
- [ bitmap>texture ] keep [ init-sprite ] keep ;
-
-:: char-sprite ( open-font sprites char -- sprite )
- char sprites [ open-font swap <char-sprite> ] cache ;
-
-: draw-char ( open-font sprites char loc -- )
- GL_MODELVIEW [
- 0 0 glTranslated
- char-sprite dlist>> glCallList
- ] do-matrix ;
-
-: char-widths ( open-font string -- widths )
- [ char-width ] with { } map-as ;
-
-: scan-sums ( seq -- seq' )
- 0 [ + ] accumulate nip ;
-
-:: (draw-string) ( open-font sprites string loc -- )
- GL_TEXTURE_2D [
- loc [
- string open-font string char-widths scan-sums [
- [ open-font sprites ] 2dip draw-char
- ] 2each
- ] with-translation
- ] do-enabled ;
-
-: font-sprites ( font world -- open-font sprites )
- fonts>> [ open-font H{ } clone 2array ] cache first2 ;
-
-M: freetype-renderer draw-string ( font string loc -- )
- [ world get font-sprites ] 2dip (draw-string) ;
-
-: run-char-widths ( open-font string -- widths )
- char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
-
-M: freetype-renderer x>offset ( x open-font string -- n )
- [ run-char-widths [ <= ] with find drop ] keep swap
- [ ] [ length ] ?if ;
-
-T{ freetype-renderer } font-renderer set-global
+++ /dev/null
-UI text rendering implementation based on FreeType
HELP: <book>
{ $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
-{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;
+{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } "." } ;
+
+HELP: <empty-book>
+{ $values { "model" model } { "book" book } }
+{ $description "Creates a " { $link book } " control with no children." }
+{ $notes "Children must be added to the book before it is grafted, otherwise an error will be thrown." } ;
ARTICLE: "ui-book-layout" "Book layouts"
-"Books can contain any number of children, and display one child at a time."
+"Books can contain any number of children, and display one child at a time. The currently visible child is determined by the value of the model, which must be an integer."
{ $subsection book }
-{ $subsection <book> } ;
+{ $subsection <book> }
+{ $subsection <empty-book> } ;
ABOUT: "ui-book-layout"
dup current-page show-gadget
relayout ;
-: new-book ( pages model class -- book )
+: new-book ( model class -- book )
new-gadget
- swap >>model
- swap add-gadgets ; inline
+ swap >>model ; inline
-: <book> ( pages model -- book ) book new-book ;
+: <book> ( pages model -- book )
+ book new-book swap add-gadgets ;
+
+: <empty-book> ( model -- book )
+ book new-book ;
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
{ $description "Creates a new border around the child with the specified horizontal and vertical gap." } ;
ARTICLE: "ui.gadgets.borders" "Border gadgets"
-"Border gadgets add empty space around a child gadget."
+"The " { $vocab-link "ui.gadgets.borders" } " vocabulary implements border gadgets, which add empty space around a child gadget."
{ $subsection border }
{ $subsection <border> } ;
{ $description "Creates a row of " { $link <command-button> } " gadgets invoking commands on " { $snippet "target" } ". The commands are taken from the " { $snippet "\"toolbar\"" } " command group of each class in " { $snippet "classes" } "." } ;
ARTICLE: "ui.gadgets.buttons" "Button gadgets"
-"Buttons respond to mouse clicks by invoking a quotation."
+"The " { $vocab-link "ui.gadgets.buttons" } " vocabulary implements buttons. Buttons respond to mouse clicks by invoking a quotation."
{ $subsection button }
"There are many ways to create a new button:"
{ $subsection <button> }
button H{
{ T{ button-up } [ button-clicked ] }
{ T{ button-down } [ button-update ] }
- { T{ mouse-leave } [ button-update ] }
- { T{ mouse-enter } [ button-update ] }
+ { mouse-leave [ button-update ] }
+ { mouse-enter [ button-update ] }
} set-gestures
: new-button ( label quot class -- button )
GL_LINE_STRIP 0 circle-steps 1+ glDrawArrays ;
:: radio-knob-theme ( gadget -- gadget )
- [let | radio-paint [ black <radio-paint> ] |
- gadget
- f f radio-paint radio-paint <button-paint> >>interior
- radio-paint >>boundary
- { 16 16 } >>dim
- ] ;
+ black <radio-paint> :> radio-paint
+ gadget
+ f f radio-paint radio-paint <button-paint> >>interior
+ radio-paint >>boundary
+ { 16 16 } >>dim ;
: <radio-knob> ( -- gadget )
<gadget> radio-knob-theme ;
align-left ; inline
M: radio-control model-changed
- swap value>>
- over value>> = >>selected?
- relayout-1 ;
+ 2dup [ value>> ] bi@ = >>selected? relayout-1 drop ;
-: <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
- '[ _ swap _ call add-gadget ] assoc-each ; inline
+:: <radio-controls> ( parent model assoc quot: ( value model label -- gadget ) -- parent )
+ assoc model [ parent swap quot call add-gadget ] assoc-each ; inline
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
: <radio-buttons> ( model assoc -- gadget )
<filled-pile>
- spin [ <radio-button> ] <radio-controls>
+ [ <radio-button> ] <radio-controls>
{ 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget )
: <toggle-buttons> ( model assoc -- gadget )
<shelf>
- spin [ <toggle-button> ] <radio-controls> ;
+ [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot )
'[ _ _ invoke-command drop ] ;
: <toolbar> ( target -- toolbar )
<shelf>
+ 1 >>fill
swap
- "toolbar" over class command-map commands>> swap
+ [ [ "toolbar" ] dip class command-map commands>> ] keep
'[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ;
: add-toolbar ( track -- track )
USING: documents help.markup help.syntax ui.gadgets
-ui.gadgets.scrollers models strings ui.commands ;
+ui.gadgets.scrollers models strings ui.commands
+ui.text colors fonts ;
IN: ui.gadgets.editors
HELP: editor
$nl
"Editors have the following slots:"
{ $list
- { { $snippet "font" } " - a font specifier." }
- { { $snippet "color" } " - text color specifier." }
- { { $snippet "caret-color" } " - caret color specifier." }
- { { $snippet "selection-color" } " - selection background color specifier." }
- { { $snippet "caret" } " - a model storing a line/column pair." }
- { { $snippet "mark" } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
+ { { $snippet "font" } " - a " { $link font } "." }
+ { { $snippet "color" } " - a " { $link color } "." }
+ { { $snippet "caret-color" } " - a " { $link color } "." }
+ { { $snippet "selection-color" } " - a " { $link color } "." }
+ { { $snippet "caret" } " - a " { $link model } " storing a line/column pair." }
+ { { $snippet "mark" } " - a " { $link model } " storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
{ { $snippet "focused?" } " - a boolean." }
} } ;
{ $values { "editor" "a new " { $link editor } } }
{ $description "Creates a new " { $link editor } " with an empty document." } ;
-{ editor-caret* editor-mark* } related-words
+{ editor-caret editor-mark } related-words
-HELP: editor-caret*
+HELP: editor-caret
{ $values { "editor" editor } { "loc" "a pair of integers" } }
{ $description "Outputs the current caret location as a line/column number pair." } ;
-HELP: editor-mark*
+HELP: editor-mark
{ $values { "editor" editor } { "loc" "a pair of integers" } }
{ $description "Outputs the current mark location as a line/column number pair." } ;
ARTICLE: "gadgets-editors-selection" "The caret and mark"
"If there is no selection, the caret and the mark are at the same location; otherwise the mark delimits the end-point of the selection opposite the caret."
-{ $subsection editor-caret* }
-{ $subsection editor-mark* }
+{ $subsection editor-caret }
+{ $subsection editor-mark }
{ $subsection change-caret }
{ $subsection change-caret&mark }
{ $subsection mark>caret }
{ $subsection scroll>caret }
"Use " { $link user-input* } " to change selected text." ;
-ARTICLE: "gadgets-editors" "Editor gadgets"
-"An editor edits a multi-line passage of text."
-{ $command-map editor "general" }
+ARTICLE: "gadgets-editors-contents" "Getting and setting editor contents"
+{ $subsection editor-string }
+{ $subsection set-editor-string }
+{ $subsection clear-editor } ;
+
+ARTICLE: "gadgets-editors-commands" "Editor gadget commands"
+{ $command-map editor "editing" }
{ $command-map editor "caret-motion" }
{ $command-map editor "selection" }
-{ $heading "Editor words" }
+{ $command-map multiline-editor "multiline" } ;
+
+ARTICLE: "gadgets-editors" "Editor gadgets"
+"The " { $vocab-link "ui.gadgets.editors" } " vocabulary implements editor gadgets. An editor edits a passage of text."
+{ $subsection "gadgets-editors-commands" }
+"Editors:"
{ $subsection editor }
{ $subsection <editor> }
-{ $subsection editor-string }
-{ $subsection set-editor-string }
+{ $subsection "gadgets-editors-contents" }
{ $subsection "gadgets-editors-selection" }
-{ $subsection "documents" }
-{ $subsection "document-locs-elts" } ;
+"Multiline editors:"
+{ $subsection <multiline-editor> }
+"Fields:"
+{ $subsection <model-field> }
+{ $subsection <action-field> }
+"Editors edit " { $emphasis "documents" } ":"
+{ $subsection "documents" } ;
ABOUT: "gadgets-editors"
USING: accessors ui.gadgets.editors tools.test kernel io
io.streams.plain definitions namespaces ui.gadgets
ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui
-models ;
+models documents.elements ;
IN: ui.gadgets.editors.tests
[ "foo bar" ] [
<editor> "editor" set
"editor" get [
"foo bar" "editor" get set-editor-string
- "editor" get T{ one-line-elt } select-elt
+ "editor" get one-line-elt select-elt
"editor" get gadget-selection
] with-grafted-gadget
] unit-test
<editor> "editor" set
"editor" get [
"foo bar\nbaz quux" "editor" get set-editor-string
- "editor" get T{ one-line-elt } select-elt
+ "editor" get one-line-elt select-elt
"editor" get gadget-selection
] with-grafted-gadget
] unit-test
\ <editor> must-infer
-"hello" <model> <field> "field" set
+"hello" <model> <model-field> "field" set
"field" get [
[ "hello" ] [ "field" get field-model>> value>> ] unit-test
] with-grafted-gadget
+
+[ "Hello world." ] [ "Hello \n world." join-lines ] unit-test
+[ " Hello world. " ] [ " Hello \n world. " join-lines ] unit-test
+[ " Hello world. Goodbye." ] [ " Hello \n world. \n Goodbye." join-lines ] unit-test
+
+[ ] [ <editor> com-join-lines ] unit-test
+[ ] [ <editor> "A" over set-editor-string com-join-lines ] unit-test
+[ "A B" ] [ <editor> "A\nB" over set-editor-string [ com-join-lines ] [ editor-string ] bi ] unit-test
\ No newline at end of file
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays documents kernel math models
-namespaces locals fry make opengl opengl.gl sequences strings
-io.styles math.vectors sorting colors combinators assocs
-math.order fry calendar alarms ui.clipboards ui.commands
-ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
-ui.gadgets.menus ui.gadgets.wrappers ui.render ui.gestures
-math.geometry.rect ;
+USING: accessors arrays documents documents.elements kernel math
+models models.filter namespaces locals fry make opengl opengl.gl
+sequences strings math.vectors sorting colors combinators assocs
+math.order fry calendar alarms continuations ui.clipboards ui.commands
+ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
+ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.menus
+ui.gadgets.wrappers ui.render ui.text ui.gestures math.geometry.rect
+splitting unicode.categories fonts ;
IN: ui.gadgets.editors
TUPLE: editor < gadget
dup caret>> deactivate-editor-model
dup mark>> deactivate-editor-model ;
-: editor-caret* ( editor -- loc ) caret>> value>> ;
+: editor-caret ( editor -- loc ) caret>> value>> ;
-: editor-mark* ( editor -- loc ) mark>> value>> ;
+: editor-mark ( editor -- loc ) mark>> value>> ;
: set-caret ( loc editor -- )
[ model>> validate-loc ] keep
caret>> set-model ;
: change-caret ( editor quot -- )
- [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi
+ [ [ [ editor-caret ] [ model>> ] bi ] dip call ] [ drop ] 2bi
set-caret ; inline
: mark>caret ( editor -- )
- [ editor-caret* ] [ mark>> ] bi set-model ;
+ [ editor-caret ] [ mark>> ] bi set-model ;
: change-caret&mark ( editor quot -- )
[ change-caret ] [ drop mark>caret ] 2bi ; inline
: editor-line ( n editor -- str ) control-value nth ;
-: editor-font* ( editor -- font ) font>> open-font ;
-
: line-height ( editor -- n )
- editor-font* "" string-height ;
+ font>> "" text-height ;
: y>line ( y editor -- line# )
line-height /i ;
[| n |
n
point first
- editor editor-font*
+ editor font>>
n editor editor-line
x>offset 2array
]
[ clicked-loc ] dip set-model ;
: focus-editor ( editor -- )
- dup start-blinking
- t >>focused?
- relayout-1 ;
+ [ start-blinking ] [ t >>focused? relayout-1 ] bi ;
: unfocus-editor ( editor -- )
- dup stop-blinking
- f >>focused?
- relayout-1 ;
-
-: offset>x ( col# line# editor -- x )
- [ editor-line ] keep editor-font* spin head-slice string-width ;
+ [ stop-blinking ] [ f >>focused? relayout-1 ] bi ;
-: loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ;
+: loc>x ( loc editor -- x )
+ [ first2 swap ] dip [ editor-line ] [ font>> ] bi swap offset>x ;
: line>y ( lines# editor -- y )
line-height * ;
-: caret-loc ( editor -- loc )
- [ editor-caret* ] keep
+: loc>point ( loc editor -- loc )
[ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
+: caret-loc ( editor -- loc )
+ [ editor-caret ] keep loc>point ;
+
: caret-dim ( editor -- dim )
line-height 0 swap 2array ;
line-translation gl-translate ;
: draw-line ( editor str -- )
- [ font>> ] dip { 0 0 } draw-string ;
+ [ font>> ] dip { 0 0 } draw-text ;
: first-visible-line ( editor -- n )
[
] with-editor-translation ;
: selection-start/end ( editor -- start end )
- [ editor-mark* ] [ editor-caret* ] bi sort-pair ;
+ [ editor-mark ] [ editor-caret ] bi sort-pair ;
: (draw-selection) ( x1 x2 -- )
- over -
- dup 0 = [ 2 + ] when
+ over - 1+
+ dup 0 = [ 1+ ] when
[ 0.0 2array ] [ editor get line-height 2array ] bi*
swap [ gl-fill-rect ] with-translation ;
: draw-selected-line ( start end n -- )
[ start/end-on-line ] keep
- tuck [ editor get offset>x ] 2bi@
+ tuck [ swap 2array editor get loc>x ] 2bi@
(draw-selection) ;
: draw-selection ( -- )
[ draw-selection draw-lines draw-caret ] with-editor ;
M: editor pref-dim*
- dup editor-font* swap control-value text-dim ;
+ [ font>> ] [ control-value ] bi text-dim ;
: contents-changed ( model editor -- )
swap
: mouse-elt ( -- element )
hand-click# get {
- { 1 T{ one-char-elt } }
- { 2 T{ one-word-elt } }
- } at T{ one-line-elt } or ;
+ { 1 one-char-elt }
+ { 2 one-word-elt }
+ } at one-line-elt or ;
: drag-direction? ( loc editor -- ? )
- editor-mark* before? ;
+ editor-mark before? ;
: drag-selection-caret ( loc editor element -- loc )
[
: drag-selection-mark ( loc editor element -- loc )
[
[ drag-direction? not ] keep
- [ editor-mark* ] [ model>> ] bi
+ [ editor-mark ] [ model>> ] bi
] dip prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark )
over gadget-selection? [
drop remove-selection
] [
- [ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
+ [ [ [ editor-caret ] [ model>> ] bi ] dip call ]
[ drop model>> ]
2bi remove-doc-range
] if ; inline
tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ;
: select-elt ( editor elt -- )
- [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
+ [ [ [ editor-caret ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
editor-select ;
-: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
+: start-of-document ( editor -- ) doc-elt editor-prev ;
-: end-of-document ( editor -- ) T{ doc-elt } editor-next ;
+: end-of-document ( editor -- ) doc-elt editor-next ;
: position-caret ( editor -- )
- mouse-elt dup T{ one-char-elt } =
+ mouse-elt dup one-char-elt =
[ drop dup extend-selection dup mark>> click-loc ]
[ select-elt ] if ;
-: insert-newline ( editor -- ) "\n" swap user-input* drop ;
-
: delete-next-character ( editor -- )
- T{ char-elt } editor-delete ;
+ char-elt editor-delete ;
: delete-previous-character ( editor -- )
- T{ char-elt } editor-backspace ;
+ char-elt editor-backspace ;
: delete-previous-word ( editor -- )
- T{ word-elt } editor-delete ;
+ word-elt editor-delete ;
: delete-next-word ( editor -- )
- T{ word-elt } editor-backspace ;
+ word-elt editor-backspace ;
: delete-to-start-of-line ( editor -- )
- T{ one-line-elt } editor-delete ;
+ one-line-elt editor-delete ;
: delete-to-end-of-line ( editor -- )
- T{ one-line-elt } editor-backspace ;
+ one-line-elt editor-backspace ;
+
+: com-undo ( editor -- )
+ model>> undo ;
+
+: com-redo ( editor -- )
+ model>> redo ;
-editor "general" f {
+editor "editing" f {
+ { undo-action com-undo }
+ { redo-action com-redo }
{ T{ key-down f f "DELETE" } delete-next-character }
{ T{ key-down f { S+ } "DELETE" } delete-next-character }
{ T{ key-down f f "BACKSPACE" } delete-previous-character }
: cut ( editor -- ) clipboard get editor-cut ;
editor "clipboard" f {
- { T{ paste-action } paste }
+ { paste-action paste }
+ { copy-action com-copy }
+ { cut-action cut }
{ T{ button-up f f 2 } paste-selection }
- { T{ copy-action } com-copy }
{ T{ button-up } com-copy-selection }
- { T{ cut-action } cut }
} define-command-map
: previous-character ( editor -- )
dup selection-start/end drop
over set-caret mark>caret
] [
- T{ char-elt } editor-prev
+ char-elt editor-prev
] if ;
: next-character ( editor -- )
dup selection-start/end nip
over set-caret mark>caret
] [
- T{ char-elt } editor-next
+ char-elt editor-next
] if ;
-: previous-line ( editor -- ) T{ line-elt } editor-prev ;
+: previous-word ( editor -- ) word-elt editor-prev ;
-: next-line ( editor -- ) T{ line-elt } editor-next ;
+: next-word ( editor -- ) word-elt editor-next ;
-: previous-word ( editor -- ) T{ word-elt } editor-prev ;
+: start-of-line ( editor -- ) one-line-elt editor-prev ;
-: next-word ( editor -- ) T{ word-elt } editor-next ;
-
-: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
-
-: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
+: end-of-line ( editor -- ) one-line-elt editor-next ;
editor "caret-motion" f {
{ T{ button-down } position-caret }
{ T{ key-down f f "LEFT" } previous-character }
{ T{ key-down f f "RIGHT" } next-character }
- { T{ key-down f f "UP" } previous-line }
- { T{ key-down f f "DOWN" } next-line }
{ T{ key-down f { C+ } "LEFT" } previous-word }
{ T{ key-down f { C+ } "RIGHT" } next-word }
{ T{ key-down f f "HOME" } start-of-line }
{ T{ key-down f { C+ } "END" } end-of-document }
} define-command-map
-: select-all ( editor -- ) T{ doc-elt } select-elt ;
+: clear-editor ( editor -- )
+ #! The with-datastack is a kludge to make it infer. Stupid.
+ model>> 1array [ clear-doc ] with-datastack drop ;
+
+: select-all ( editor -- ) doc-elt select-elt ;
-: select-line ( editor -- ) T{ one-line-elt } select-elt ;
+: select-line ( editor -- ) one-line-elt select-elt ;
-: select-word ( editor -- ) T{ one-word-elt } select-elt ;
+: select-word ( editor -- ) one-word-elt select-elt ;
-: selected-word ( editor -- string )
+: selected-token ( editor -- string )
dup gadget-selection?
[ dup select-word ] unless
gadget-selection ;
: select-previous-character ( editor -- )
- T{ char-elt } editor-select-prev ;
+ char-elt editor-select-prev ;
: select-next-character ( editor -- )
- T{ char-elt } editor-select-next ;
-
-: select-previous-line ( editor -- )
- T{ line-elt } editor-select-prev ;
-
-: select-next-line ( editor -- )
- T{ line-elt } editor-select-next ;
+ char-elt editor-select-next ;
: select-previous-word ( editor -- )
- T{ word-elt } editor-select-prev ;
+ word-elt editor-select-prev ;
: select-next-word ( editor -- )
- T{ word-elt } editor-select-next ;
+ word-elt editor-select-next ;
: select-start-of-line ( editor -- )
- T{ one-line-elt } editor-select-prev ;
+ one-line-elt editor-select-prev ;
: select-end-of-line ( editor -- )
- T{ one-line-elt } editor-select-next ;
+ one-line-elt editor-select-next ;
: select-start-of-document ( editor -- )
- T{ doc-elt } editor-select-prev ;
+ doc-elt editor-select-prev ;
: select-end-of-document ( editor -- )
- T{ doc-elt } editor-select-next ;
+ doc-elt editor-select-next ;
editor "selection" f {
{ T{ button-down f { S+ } 1 } extend-selection }
{ T{ drag } drag-selection }
- { T{ gain-focus } focus-editor }
- { T{ lose-focus } unfocus-editor }
- { T{ delete-action } remove-selection }
- { T{ select-all-action } select-all }
+ { gain-focus focus-editor }
+ { lose-focus unfocus-editor }
+ { delete-action remove-selection }
+ { select-all-action select-all }
{ T{ key-down f { C+ } "l" } select-line }
{ T{ key-down f { S+ } "LEFT" } select-previous-character }
{ T{ key-down f { S+ } "RIGHT" } select-next-character }
- { T{ key-down f { S+ } "UP" } select-previous-line }
- { T{ key-down f { S+ } "DOWN" } select-next-line }
{ T{ key-down f { S+ C+ } "LEFT" } select-previous-word }
{ T{ key-down f { S+ C+ } "RIGHT" } select-next-word }
{ T{ key-down f { S+ } "HOME" } select-start-of-line }
: <multiline-editor> ( -- editor )
multiline-editor new-editor ;
-multiline-editor "general" f {
+: previous-line ( editor -- ) line-elt editor-prev ;
+
+: next-line ( editor -- ) line-elt editor-next ;
+
+: select-previous-line ( editor -- )
+ line-elt editor-select-prev ;
+
+: select-next-line ( editor -- )
+ line-elt editor-select-next ;
+
+: insert-newline ( editor -- )
+ "\n" swap user-input* drop ;
+
+: change-selection ( editor quot -- )
+ '[ gadget-selection @ ] keep user-input* drop ; inline
+
+: join-lines ( string -- string' )
+ "\n" split
+ [ rest-slice [ [ blank? ] trim-head-slice ] change-each ]
+ [ but-last-slice [ [ blank? ] trim-tail-slice ] change-each ]
+ [ " " join ]
+ tri ;
+
+: this-line-and-next ( document line -- start end )
+ [ nip 0 swap 2array ]
+ [ [ nip 1+ ] [ 1+ swap doc-line length ] 2bi 2array ]
+ 2bi ;
+
+: last-line? ( document line -- ? )
+ [ last-line# ] dip = ;
+
+: com-join-lines ( editor -- )
+ dup gadget-selection?
+ [ [ join-lines ] change-selection ] [
+ [ model>> ] [ editor-caret first ] bi
+ 2dup last-line? [ 2drop ] [
+ [ this-line-and-next ] [ drop ] 2bi
+ [ join-lines ] change-doc-range
+ ] if
+ ] if ;
+
+multiline-editor "multiline" f {
+ { T{ key-down f f "UP" } previous-line }
+ { T{ key-down f f "DOWN" } next-line }
+ { T{ key-down f { S+ } "UP" } select-previous-line }
+ { T{ key-down f { S+ } "DOWN" } select-next-line }
{ T{ key-down f f "RET" } insert-newline }
{ T{ key-down f { S+ } "RET" } insert-newline }
{ T{ key-down f f "ENTER" } insert-newline }
+ { T{ key-down f { C+ } "j" } com-join-lines }
} define-command-map
TUPLE: source-editor < multiline-editor ;
: <source-editor> ( -- editor )
source-editor new-editor ;
-! Fields wrap an editor and edit an external model
-TUPLE: field < wrapper field-model editor ;
+! A useful model
+: <element-model> ( editor element -- model )
+ [ [ caret>> ] [ model>> ] bi ] dip
+ '[ _ _ elt-string ] <filter> ;
+
+! Fields wrap an editor
+TUPLE: field < wrapper editor min-width max-width ;
: field-theme ( gadget -- gadget )
gray <solid> >>boundary ; inline
{ 1 0 } >>fill
field-theme ;
-: <field> ( model -- gadget )
- <editor> dup <field-border> field new-wrapper
- swap >>editor
- swap >>field-model ;
+: new-field ( class -- gadget )
+ [ <editor> dup <field-border> ] dip new-wrapper swap >>editor ; inline
+
+: column-width ( editor n -- width )
+ [ editor>> font>> ] [ CHAR: \s <string> ] bi* text-width ;
+
+M: field pref-dim*
+ [ call-next-method ]
+ [ dup min-width>> dup [ column-width 0 2array vmax ] [ 2drop ] if ]
+ [ dup max-width>> dup [ column-width 1/0. 2array vmin ] [ 2drop ] if ]
+ tri ;
+
+TUPLE: model-field < field field-model ;
-M: field graft*
+: <model-field> ( model -- gadget )
+ model-field new-field swap >>field-model ;
+
+M: model-field graft*
[ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
[ dup editor>> model>> add-connection ]
bi ;
-M: field ungraft*
+M: model-field ungraft*
dup editor>> model>> remove-connection ;
-M: field model-changed
+M: model-field model-changed
nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
+
+TUPLE: action-field < field quot ;
+
+: <action-field> ( quot -- gadget )
+ action-field new-field swap >>quot ;
+
+: invoke-action-field ( field -- )
+ [ editor>> editor-string ]
+ [ editor>> clear-editor ]
+ [ quot>> ]
+ tri call ;
+
+action-field H{
+ { T{ key-down f f "RET" } [ invoke-action-field ] }
+} set-gestures
dup unparent
over >>parent
tuck ((add-gadget))
- tuck graft-state>> second [ graft ] [ drop ] if ;
+ tuck graft-state>> second [ graft ] [ drop ] if ;
: add-gadget ( parent child -- parent )
not-in-layout
--- /dev/null
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces ui.gadgets ui.gadgets.worlds
+ui.gestures ;
+IN: ui.gadgets.glass
+
+GENERIC: hide-glass-hook ( gadget -- )
+
+M: gadget hide-glass-hook drop ;
+
+TUPLE: glass < gadget ;
+
+: <glass> ( child loc -- glass )
+ >>loc glass new-gadget swap add-gadget ;
+
+M: glass layout* gadget-child prefer ;
+
+M: glass ungraft* gadget-child hide-glass-hook ;
+
+: hide-glass ( world -- )
+ [ [ unparent ] when* f ] change-glass drop ;
+
+: show-glass ( world child loc -- )
+ <glass>
+ [ [ hide-glass ] [ hand-clicked set-global ] bi* ]
+ [ [ add-gadget ] [ >>glass ] bi drop ]
+ 2bi ;
+
+\ glass H{
+ { T{ button-down } [ find-world [ hide-glass ] when* ] }
+ { T{ drag } [ update-clicked drop ] }
+} set-gestures
\ No newline at end of file
USING: ui.gadgets help.markup help.syntax ui.gadgets.grids
-ui.render ;
+ui.render colors ;
IN: ui.gadgets.grid-lines
HELP: grid-lines
-{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $snippet "color" } " slot." } ;
+{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is an instance of " { $link color } ", stored in the " { $snippet "color" } " slot." }
+{ $notes "See " { $link "colors" } "." } ;
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math namespaces opengl opengl.gl
sequences math.vectors ui.gadgets ui.gadgets.grids ui.render
: half-gap ( -- gap ) grid get gap>> [ 2/ ] map ; inline
: grid-line-from/to ( orientation point -- from to )
- half-gap v-
- [ half-gap spin set-axis ] 2keep
- grid-dim get spin set-axis ;
+ half-gap v- swap
+ [ [ half-gap ] 2dip set-axis ]
+ [ [ grid-dim get ] 2dip set-axis ] 2bi ;
: draw-grid-lines ( gaps orientation -- )
[ grid get swap grid-positions grid get rect-dim suffix ] dip
M: grid-lines draw-boundary
color>> gl-color [
- dup grid set
- dup rect-dim half-gap v- grid-dim set
- compute-grid
+ [ grid set ]
+ [ rect-dim half-gap v- grid-dim set ]
+ [ compute-grid ] tri
[ { 1 0 } draw-grid-lines ]
[ { 0 1 } draw-grid-lines ]
bi*
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces make sequences words io
-io.styles math.vectors ui.gadgets columns accessors
+math.vectors ui.gadgets columns accessors strings.tables
math.geometry.rect locals fry ;
IN: ui.gadgets.grids
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces math.vectors ui.gadgets
-ui.gadgets.packs accessors math.geometry.rect ;
+ui.gadgets.packs accessors math.geometry.rect combinators ;
IN: ui.gadgets.incremental
TUPLE: incremental < pack cursor ;
[ cursor>> ] [ orientation>> ] bi v*
>>loc drop ;
-: prefer-incremental ( gadget -- ) USE: slots.private
+: prefer-incremental ( gadget -- )
dup forget-pref-dim dup pref-dim >>dim drop ;
M: incremental dim-changed drop ;
not-in-layout
2dup swap (add-gadget) drop
t in-layout? [
- over prefer-incremental
- over layout-later
- 2dup incremental-loc
- tuck update-cursor
- dup prefer-incremental
- parent>> [ invalidate* ] when*
+ {
+ [ drop prefer-incremental ]
+ [ drop layout-later ]
+ [ incremental-loc ]
+ [ update-cursor ]
+ [ nip prefer-incremental ]
+ [ nip parent>> [ invalidate* ] when* ]
+ } 2cleave
] with-variable ;
: clear-incremental ( incremental -- )
not-in-layout
- dup (clear-gadget)
- dup forget-pref-dim
- { 0 0 } >>cursor
- parent>> [ relayout ] when* ;
+ [ (clear-gadget) ]
+ [ forget-pref-dim ]
+ [ { 0 0 } >>cursor parent>> [ relayout ] when* ]
+ tri ;
{ <labelled-pane> <pane-control> } related-words
ARTICLE: "ui.gadgets.labelled" "Labelled gadgets"
-"It is possible to create a labelled border around a child gadget:"
+"The " { $vocab-link "ui.gadgets.labelled" } " vocabulary implements labelled borders around child gadgets."
{ $subsection labelled-gadget }
{ $subsection <labelled-gadget> }
"Or a labelled border with a close box:"
{ <label> <label-control> } related-words
ARTICLE: "ui.gadgets.labels" "Label gadgets"
-"A label displays a piece of text, either a single line string or an array of line strings."
+"The " { $vocab-link "ui.gadgets.labels" } " vocabulary implements labels. A label displays a piece of text, either a single line string or an array of line strings."
{ $subsection label }
{ $subsection <label> }
{ $subsection <label-control> }
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables io kernel math namespaces
make opengl sequences strings splitting ui.gadgets
-ui.gadgets.tracks ui.gadgets.theme ui.render colors models ;
+ui.gadgets.tracks fonts ui.render
+ui.text colors models ;
IN: ui.gadgets.labels
! A label gadget draws a string.
-TUPLE: label < gadget text font color ;
+TUPLE: label < gadget text font ;
: label-string ( label -- string )
text>> dup string? [ "\n" join ] unless ; inline
[ CHAR: \n over memq? [ string-lines ] when ] dip (>>text) ; inline
: label-theme ( gadget -- gadget )
- sans-serif-font >>font
- black >>color ; inline
+ sans-serif-font >>font ; inline
: new-label ( string class -- label )
new-gadget
label new-label ;
M: label pref-dim*
- [ font>> open-font ] [ text>> ] bi text-dim ;
+ [ font>> ] [ text>> ] bi text-dim ;
M: label draw-gadget*
- [ color>> gl-color ]
- [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
+ [ font>> ] [ text>> ] bi origin get draw-text ;
M: label gadget-text* label-string % ;
swap >>model ;
: text-theme ( gadget -- gadget )
- black >>color
monospace-font >>font ;
: reverse-video-theme ( label -- label )
- white >>color
- black solid-interior ;
+ sans-serif-font reverse-video-font >>font ;
GENERIC: >label ( obj -- gadget )
M: string >label <label> ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.commands help.markup help.syntax ui.gadgets
-ui.gadgets.presentations ui.operations kernel models classes ;
-IN: ui.gadgets.lists
-
-HELP: +secondary+
-{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when " { $snippet "RET" } " is pressed in a " { $link list } " gadget where the current selection is a presentation matching the operation's predicate." } ;
-
-HELP: list
-{ $class-description
- "A list control is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
- $nl
- "Lists are created by calling " { $link <list> } "."
- { $command-map list "keyboard-navigation" }
-} ;
-
-HELP: <list>
-{ $values { "hook" { $quotation "( list -- )" } } { "presenter" { $quotation "( object -- label )" } } { "model" model } { "gadget" list } }
-{ $description "Creates a new " { $link list } "."
-$nl
-"The model value must be a sequence. The list displays presentations of elements with labels obtained by applying the " { $snippet "presenter" } " quotation to each object. The " { $snippet "hook" } " quotation is called when a presentation is selected." } ;
-
-HELP: list-value
-{ $values { "list" list } { "object" object } }
-{ $description "Outputs the currently selected list value." } ;
-
-ARTICLE: "ui.gadgets.lists" "List gadgets"
-"A list displays a list of presentations."
-{ $subsection list }
-{ $subsection <list> }
-{ $subsection list-value } ;
-
-ABOUT: "ui.gadgets.lists"
+++ /dev/null
-IN: ui.gadgets.lists.tests
-USING: ui.gadgets.lists models prettyprint math tools.test
-kernel ;
-
-[ ] [ [ drop ] [ 3 + . ] f <model> <list> invoke-value-action ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ui.commands ui.gestures ui.render ui.gadgets
-ui.gadgets.labels ui.gadgets.scrollers
-kernel sequences models opengl math math.order namespaces
-ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
-math.vectors classes.tuple math.geometry.rect colors ;
-
-IN: ui.gadgets.lists
-
-TUPLE: list < pack index presenter color hook ;
-
-: list-theme ( list -- list )
- T{ rgba f 0.8 0.8 1.0 1.0 } >>color ; inline
-
-: <list> ( hook presenter model -- gadget )
- list new-gadget
- { 0 1 } >>orientation
- 1 >>fill
- 0 >>index
- swap >>model
- swap >>presenter
- swap >>hook
- list-theme ;
-
-: calc-bounded-index ( n list -- m )
- control-value length 1- min 0 max ;
-
-: bound-index ( list -- )
- dup index>> over calc-bounded-index >>index drop ;
-
-: list-presentation-hook ( list -- quot )
- hook>> [ [ list? ] find-parent ] prepend ;
-
-: <list-presentation> ( hook elt presenter -- gadget )
- keep [ >label text-theme ] dip
- <presentation>
- swap >>hook ; inline
-
-: <list-items> ( list -- seq )
- [ list-presentation-hook ]
- [ presenter>> ]
- [ control-value ]
- tri [
- [ 2dup ] dip swap <list-presentation>
- ] map 2nip ;
-
-M: list model-changed
- nip
- dup clear-gadget
- dup <list-items> add-gadgets
- bound-index ;
-
-: selected-rect ( list -- rect )
- dup index>> swap children>> ?nth ;
-
-M: list draw-gadget*
- origin get [
- dup color>> gl-color
- selected-rect [
- dup loc>> [
- dim>> gl-fill-rect
- ] with-translation
- ] when*
- ] with-translation ;
-
-M: list focusable-child* drop t ;
-
-: list-value ( list -- object )
- dup index>> swap control-value ?nth ;
-
-: scroll>selected ( list -- )
- #! We change the rectangle's width to zero to avoid
- #! scrolling right.
- [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
- scroll>rect ;
-
-: list-empty? ( list -- ? ) control-value empty? ;
-
-: select-index ( n list -- )
- dup list-empty? [
- 2drop
- ] [
- [ control-value length rem ] keep
- swap >>index
- dup relayout-1
- scroll>selected
- ] if ;
-
-: select-previous ( list -- )
- dup index>> 1- swap select-index ;
-
-: select-next ( list -- )
- dup index>> 1+ swap select-index ;
-
-: invoke-value-action ( list -- )
- dup list-empty? [
- dup hook>> call
- ] [
- dup index>> swap nth-gadget invoke-secondary
- ] if ;
-
-: select-gadget ( gadget list -- )
- tuck children>> index
- [ swap select-index ] [ drop ] if* ;
-
-: clamp-loc ( point max -- point )
- vmin { 0 0 } vmax ;
-
-: select-at ( point list -- )
- [ rect-dim clamp-loc ] keep
- [ pick-up ] keep
- select-gadget ;
-
-: list-page ( list vec -- )
- [ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
- v* v+ swap select-at ;
-
-: list-page-up ( list -- ) { 0 -1 } list-page ;
-
-: list-page-down ( list -- ) { 0 1 } list-page ;
-
-list "keyboard-navigation" "Lists can be navigated from the keyboard." {
- { T{ button-down } request-focus }
- { T{ key-down f f "UP" } select-previous }
- { T{ key-down f f "DOWN" } select-next }
- { T{ key-down f f "PAGE_UP" } list-page-up }
- { T{ key-down f f "PAGE_DOWN" } list-page-down }
- { T{ key-down f f "RET" } invoke-value-action }
-} define-command-map
+++ /dev/null
-List gadgets display a keyboard-navigatable list of presentations
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals accessors arrays ui.commands ui.operations ui.gadgets
-ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic
-hashtables kernel math models namespaces opengl sequences
-math.vectors ui.gadgets.theme ui.gadgets.packs
-ui.gadgets.borders colors math.geometry.rect ;
+USING: locals accessors kernel math namespaces sequences
+math.vectors colors math.geometry.rect ui.commands ui.operations ui.gadgets
+ui.gadgets.buttons ui.gadgets.worlds ui.gestures ui.gadgets.theme
+ui.gadgets.packs ui.gadgets.glass ui.gadgets.borders ;
IN: ui.gadgets.menus
: menu-loc ( world menu -- loc )
- [ rect-dim ] [ pref-dim ] bi* [v-] hand-loc get-global vmin ;
-
-TUPLE: menu-glass < gadget ;
-
-: <menu-glass> ( world menu -- glass )
- tuck menu-loc >>loc
- menu-glass new-gadget
- swap add-gadget ;
-
-M: menu-glass layout* gadget-child prefer ;
-
-: hide-glass ( world -- )
- [ [ unparent ] when* f ] change-glass drop ;
-
-: show-glass ( world gadget -- )
- [ [ hide-glass ] [ hand-clicked set-global ] bi* ]
- [ add-gadget drop ]
- [ >>glass drop ]
- 2tri ;
+ [ dim>> ] [ pref-dim ] bi* [v-] hand-loc get-global vmin ;
: show-menu ( owner menu -- )
- [ find-world dup ] dip <menu-glass> show-glass ;
-
-\ menu-glass H{
- { T{ button-down } [ find-world [ hide-glass ] when* ] }
- { T{ drag } [ update-clicked drop ] }
-} set-gestures
+ [ find-world ] dip 2dup menu-loc show-glass ;
:: <menu-item> ( target hook command -- button )
command command-name [
: <operations-menu> ( target hook -- menu )
over object-operations <commands-menu> ;
-: show-operations-menu ( gadget target -- )
- [ ] <operations-menu> show-menu ;
\ No newline at end of file
+: show-operations-menu ( gadget target hook -- )
+ <operations-menu> show-menu ;
\ No newline at end of file
{ with-pane make-pane } related-words
ARTICLE: "ui.gadgets.panes" "Pane gadgets"
-"A pane displays formatted text."
+"The " { $vocab-link "ui.gadgets.panes" } " vocabulary implements panes, which display formatted text."
{ $subsection pane }
{ $subsection <pane> }
{ $subsection <scrolling-pane> }
kernel sequences io io.styles io.streams.string tools.test
prettyprint definitions help help.syntax help.markup
help.stylesheet splitting tools.test.ui models math summary
-inspector accessors ;
+inspector accessors help.topics ;
IN: ui.gadgets.panes.tests
: #children "pane" get children>> length ;
] test-gadget-text
] unit-test
+[ t ] [
+ [
+ last-element off
+ \ = >link $title
+ "Hello world" print-content
+ ] test-gadget-text
+] unit-test
+
ARTICLE: "test-article-1" "This is a test article"
"Hello world, how are you today." ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+USING: arrays hashtables io kernel namespaces sequences
+io.styles strings quotations math opengl combinators memoize
+math.vectors sorting splitting assocs classes.tuple models
+continuations destructors accessors math.geometry.rect fry
+fonts ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
-hashtables io kernel namespaces sequences io.styles strings
-quotations math opengl combinators math.vectors sorting
-splitting assocs ui.gadgets.presentations
-ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
-classes.tuple models continuations destructors accessors
-math.geometry.rect fry ;
+ui.text ui.gadgets.presentations ui.gadgets.grids
+ui.gadgets.grid-lines colors ;
IN: ui.gadgets.panes
TUPLE: pane < pack
: clear-selection ( pane -- pane )
f >>caret f >>mark ;
-: add-output ( pane current -- pane )
- [ >>output ] [ add-gadget ] bi ;
+: add-output ( pane current -- pane )
+ [ >>output ] [ add-gadget ] bi ;
: add-current ( pane current -- pane )
[ >>current ] [ add-gadget ] bi ;
-: prepare-line ( pane -- pane )
+: prepare-line ( pane -- )
clear-selection
- dup prototype>> clone add-current ;
+ dup prototype>> clone add-current drop ;
: pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ;
{ 0 1 } >>orientation
<shelf> >>prototype
<incremental> add-output
- prepare-line
+ dup prepare-line
selection-color >>selection-color ;
: <pane> ( -- pane ) pane new-pane ;
M: pane draw-gadget*
dup gadget-selection? [
- dup selection-color>> gl-color
- origin get over rect-loc v- swap selected-children
- [ draw-selection ] with each
- ] [
- drop
- ] if ;
+ [ selection-color>> gl-color ]
+ [
+ [ [ origin get ] dip loc>> v- ] keep selected-children
+ [ draw-selection ] with each
+ ] bi
+ ] [ drop ] if ;
: scroll-pane ( pane -- )
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
: smash-pane ( pane -- gadget ) output>> smash-line ;
-: pane-nl ( pane -- pane )
- dup current>> dup unparent smash-line
- over output>> add-incremental
- prepare-line ;
+: pane-nl ( pane -- )
+ [
+ [ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
+ add-incremental
+ ]
+ [ prepare-line ] bi ;
-: pane-write ( pane seq -- )
- [ pane-nl ]
- [ over current>> stream-write ]
- interleave drop ;
+: pane-write ( seq pane -- )
+ [ '[ _ pane-nl ] ]
+ [ '[ _ current>> stream-write ] ] bi
+ interleave ;
-: pane-format ( style pane seq -- )
- [ pane-nl ]
- [ 2over current>> stream-format ]
- interleave 2drop ;
+: pane-format ( seq style pane -- )
+ [ '[ _ drop _ pane-nl ] ]
+ [ '[ _ _ current>> stream-format ] ] 2bi
+ interleave ;
GENERIC: write-gadget ( gadget stream -- )
stream>> write-gadget ;
: print-gadget ( gadget stream -- )
- tuck write-gadget stream-nl ;
+ [ write-gadget ] [ nip stream-nl ] 2bi ;
: gadget. ( gadget -- )
output-stream get print-gadget ;
[ pane>> ] dip keep scroll-pane ; inline
M: pane-stream stream-nl
- [ pane-nl drop ] do-pane-stream ;
+ [ pane-nl ] do-pane-stream ;
M: pane-stream stream-write1
[ current>> stream-write1 ] do-pane-stream ;
M: pane-stream stream-write
- [ swap string-lines pane-write ] do-pane-stream ;
+ [ [ string-lines ] dip pane-write ] do-pane-stream ;
M: pane-stream stream-format
- [ rot string-lines pane-format ] do-pane-stream ;
+ [ [ string-lines ] 2dip pane-format ] do-pane-stream ;
M: pane-stream dispose drop ;
! Character styles
-: apply-style ( style gadget key quot -- style gadget )
- [ pick at ] dip when* ; inline
-
-: apply-foreground-style ( style gadget -- style gadget )
- foreground [ >>color ] apply-style ;
-
-: apply-background-style ( style gadget -- style gadget )
- background [ solid-interior ] apply-style ;
-
-: specified-font ( style -- font )
- [ font swap at "monospace" or ] keep
- [ font-style swap at plain or ] keep
- font-size swap at 12 or 3array ;
+MEMO: specified-font ( assoc -- font )
+ #! We memoize here to avoid creating lots of duplicate font objects.
+ [ <font> ] dip
+ {
+ [ font-name swap at "monospace" or >>name ]
+ [
+ font-style swap at {
+ { f [ ] }
+ { plain [ ] }
+ { bold [ t >>bold? ] }
+ { italic [ t >>italic? ] }
+ { bold-italic [ t >>bold? t >>italic? ] }
+ } case
+ ]
+ [ font-size swap at 12 or >>size ]
+ [ foreground swap at black or >>foreground ]
+ [ background swap at white or >>background ]
+ } cleave ;
: apply-font-style ( style gadget -- style gadget )
- over specified-font >>font ;
+ { font-name font-style font-size foreground background }
+ pick extract-keys specified-font >>font ;
+
+: apply-style ( style gadget key quot -- style gadget )
+ [ pick at ] dip when* ; inline
: apply-presentation-style ( style gadget -- style gadget )
presented [ <presentation> ] apply-style ;
: style-label ( style gadget -- gadget )
- apply-foreground-style
- apply-background-style
apply-font-style
apply-presentation-style
nip ; inline
: apply-page-color-style ( style gadget -- style gadget )
page-color [ solid-interior ] apply-style ;
-: apply-path-style ( style gadget -- style gadget )
- presented-path [ <editable-slot> ] apply-style ;
-
: apply-border-width-style ( style gadget -- style gadget )
border-width [ <border> ] apply-style ;
-: apply-printer-style ( style gadget -- style gadget )
- presented-printer [ '[ _ make-pane ] >>printer ] apply-style ;
-
: style-pane ( style pane -- pane )
apply-border-width-style
apply-border-color-style
apply-page-color-style
apply-presentation-style
- apply-path-style
- apply-printer-style
nip ;
TUPLE: nested-pane-stream < pane-stream style parent ;
[ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
: gadget-format ( string style stream -- )
- spin dup empty?
- [ 3drop ] [ <styled-label> add-gadget drop ] if ;
+ '[ _ swap <styled-label> _ swap add-gadget drop ] unless-empty ;
M: pack stream-format
gadget-format ;
presented pick at [
gadget-format
] [
- rot " " split
- [ 2dup gadget-bl ]
- [ 2over gadget-format ] interleave
- 2drop
+ [ " " split ] 2dip
+ [ '[ _ _ gadget-bl ] ]
+ [ '[ _ _ gadget-format ] ] 2bi
+ interleave
] if ;
: caret>mark ( pane -- pane )
{ T{ button-up f { S+ } 1 } [ end-selection ] }
{ T{ button-up } [ end-selection ] }
{ T{ drag } [ extend-selection ] }
- { T{ copy-action } [ com-copy ] }
+ { copy-action [ com-copy ] }
{ T{ button-down f f 3 } [ pane-menu ] }
} set-gestures
{ $description "Displays a " { $link summary } " of the " { $snippet "object" } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ;
ARTICLE: "ui.gadgets.presentations" "Presentation gadgets"
-"Outliner gadgets are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (" { $link "presentations" } ")."
+"The " { $vocab-link "ui.gadgets.presentations" } " vocabulary implements presentations, which are graphical representations of an object, associated with the object itself (see " { $link "ui-operations" } ")."
+$nl
+"Clicking a presentation with the left mouse button invokes the object's primary operation, and clicking with the right mouse button displays a menu of all applicable operations. Presentations are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (see " { $link "presentations" } ")."
{ $subsection presentation }
-{ $subsection <presentation> }
-"Presentations remember the object they are presenting; operations can be performed on the presented object. See " { $link "ui-operations" } "." ;
+{ $subsection <presentation> } ;
ABOUT: "ui.gadgets.presentations"
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors definitions hashtables io kernel
-sequences strings io.styles words help math models
-namespaces quotations
+sequences strings words help math models namespaces quotations
ui.gadgets ui.gadgets.borders ui.gadgets.buttons
ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
dup hand-gadget get-global child? [ dup hide-status ] when
call-next-method ;
-: show-operations-menu ( presentation -- )
+: show-presentation-menu ( presentation -- )
[ ] [ object>> ] [ dup hook>> curry ] tri
- <operations-menu> show-menu ;
+ show-operations-menu ;
presentation H{
- { T{ button-down f f 3 } [ show-operations-menu ] }
- { T{ mouse-leave } [ [ hide-status ] [ button-update ] bi ] }
- { T{ mouse-enter } [ show-mouse-help ] }
+ { T{ button-down f f 3 } [ show-presentation-menu ] }
+ { mouse-leave [ [ hide-status ] [ button-update ] bi ] }
+ { mouse-enter [ show-mouse-help ] }
! Responding to motion too allows nested presentations to
! display status help properly, when the mouse leaves a
! nested presentation and is still inside the parent, the
! parent doesn't receive a mouse-enter
- { T{ motion } [ show-mouse-help ] }
+ { motion [ show-mouse-help ] }
} set-gestures
{ $description "Ensures that any scroller containing " { $snippet "gadget" } " is scrolled all the way up. If no parent of " { $snippet "scroller" } " is a gadget, does nothing." } ;
ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets"
-"A scroller displays a gadget which is larger than the visible area."
+"The " { $vocab-link "ui.gadgets.scrollers" } " vocabulary implements scroller gadgets. A scroller displays a gadget which is larger than the visible area."
{ $subsection scroller }
{ $subsection <scroller> }
"Getting and setting the scroll position:"
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
2bi ;
scroller H{
- { T{ mouse-scroll } [ do-mouse-scroll ] }
+ { mouse-scroll [ do-mouse-scroll ] }
} set-gestures
: <scroller-model> ( -- model )
[ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
: (scroll>rect) ( rect scroller -- )
- [ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
+ [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
{
[ scroller-value vneg offset-rect viewport-gap offset-rect ]
[ viewport>> dim>> rect-min ]
: (scroll>gadget) ( gadget scroller -- )
2dup swap child? [
- [ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
+ [ [ [ { 0 0 } ] dip pref-dim <rect> ] keep ] dip
[ relative-scroll-rect ] keep
(scroll>rect)
] [ f >>follows (update-scroller) drop ] if ;
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel delegate fry sequences
+models models.search models.delay calendar locals
+ui.gadgets.editors ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.tables ui.gadgets.tracks ui.gadgets.borders
+ui.gadgets.buttons ;
+IN: ui.gadgets.search-tables
+
+TUPLE: search-field < track field ;
+
+: clear-search-field ( search-field -- )
+ field>> editor>> clear-editor ;
+
+: <clear-button> ( search-field -- button )
+ "X" swap '[ drop _ clear-search-field ] <roll-button> ;
+
+: <search-field> ( model -- gadget )
+ { 1 0 } search-field new-track
+ { 5 5 } >>gap
+ "Search:" <label> f track-add
+ swap <model-field> 10 >>min-width >>field
+ dup field>> 1 track-add
+ dup <clear-button> f track-add ;
+
+TUPLE: search-table < track table field ;
+
+! A protocol with customizable slots
+SLOT-PROTOCOL: table-protocol
+renderer
+filled-column
+column-alignment
+action
+hook
+font
+text-color
+selection-color
+focus-border-color
+mouse-color
+column-line-color
+selection-required?
+selected-value ;
+
+CONSULT: table-protocol search-table table>> ;
+
+:: <search-table> ( values quot -- gadget )
+ f <model> :> search
+ { 0 1 } search-table new-track
+ values >>model
+ search <search-field> >>field
+ dup field>> 2 <filled-border> f track-add
+ values search 500 milliseconds <delay> quot <search> <table> >>table
+ dup table>> <scroller> 1 track-add ;
+
+M: search-table model-changed
+ nip field>> clear-search-field ;
\ No newline at end of file
{ <x-slider> <y-slider> } related-words
ARTICLE: "ui.gadgets.sliders" "Slider gadgets"
-"A slider allows the user to graphically manipulate a value by moving a thumb back and forth."
+"The " { $vocab-link "ui.gadgets.sliders" } " vocabulary implements slider gadgets. A slider allows the user to graphically manipulate a value by moving a thumb back and forth."
{ $subsection slider }
{ $subsection <x-slider> }
{ $subsection <y-slider> }
IN: ui.gadgets.slots.tests
USING: assocs ui.gadgets.slots tools.test refs ;
-\ <editable-slot> must-infer
-
-[ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
+[ t ] [ [ ] [ ] { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel parser prettyprint
sequences arrays io math definitions math.vectors assocs refs
ui.gadgets ui.gestures ui.commands ui.gadgets.scrollers
ui.gadgets.buttons ui.gadgets.borders ui.gadgets.tracks
-ui.gadgets.editors eval ;
+ui.gadgets.editors eval continuations ;
IN: ui.gadgets.slots
TUPLE: update-object ;
TUPLE: edit-slot ;
-TUPLE: slot-editor < track ref text ;
+TUPLE: slot-editor < track ref close-hook update-hook text ;
: revert ( slot-editor -- )
- dup ref>> get-ref unparse-use
- swap text>> set-editor-string ;
+ [ ref>> get-ref unparse-use ] [ text>> ] bi set-editor-string ;
\ revert H{
{ +description+ "Revert any uncomitted changes." }
} define-command
-GENERIC: finish-editing ( slot-editor ref -- )
+: close ( slot-editor -- )
+ dup close-hook>> call ;
-M: key-ref finish-editing
- drop T{ update-object } swap propagate-gesture ;
+\ close H{
+ { +description+ "Close the slot editor without saving changes." }
+} define-command
-M: value-ref finish-editing
- drop T{ update-slot } swap propagate-gesture ;
+: close-and-update ( slot-editor -- )
+ [ update-hook>> call ] [ close ] bi ;
: slot-editor-value ( slot-editor -- object )
- text>> control-value parse-fresh ;
+ text>> control-value parse-fresh first ;
: commit ( slot-editor -- )
- dup text>> control-value parse-fresh first
- over ref>> set-ref
- dup ref>> finish-editing ;
+ [ [ slot-editor-value ] [ ref>> ] bi set-ref ]
+ [ close-and-update ]
+ bi ;
\ commit H{
{ +description+ "Parse the object being edited, and store the result back into the edited slot." }
} define-command
+: eval-1 ( string -- object )
+ 1array [ eval ] with-datastack first ;
+
: com-eval ( slot-editor -- )
- [ text>> editor-string eval ] keep
- [ ref>> set-ref ] keep
- dup ref>> finish-editing ;
+ [ [ text>> editor-string eval-1 ] [ ref>> ] bi set-ref ]
+ [ close-and-update ]
+ bi ;
\ com-eval H{
{ +listener+ t }
} define-command
: delete ( slot-editor -- )
- dup ref>> delete-ref
- T{ update-object } swap propagate-gesture ;
+ [ ref>> delete-ref ] [ close-and-update ] bi ;
\ delete H{
{ +description+ "Delete the slot and close the slot editor." }
} define-command
-: close ( slot-editor -- )
- T{ update-slot } swap propagate-gesture ;
-
-\ close H{
- { +description+ "Close the slot editor without saving changes." }
-} define-command
-
-: <slot-editor> ( ref -- gadget )
+: <slot-editor> ( close-hook update-hook ref -- gadget )
{ 0 1 } slot-editor new-track
swap >>ref
+ swap >>update-hook
+ swap >>close-hook
add-toolbar
<source-editor> >>text
dup text>> <scroller> 1 track-add
{ f delete }
{ T{ key-down f f "ESC" } close }
} define-command-map
-
-TUPLE: editable-slot < track printer ref ;
-
-: <edit-button> ( -- gadget )
- "..."
- [ T{ edit-slot } swap propagate-gesture ]
- <roll-button> ;
-
-: display-slot ( gadget editable-slot -- )
- dup clear-track
- swap 1 track-add
- <edit-button> f track-add
- drop ;
-
-: update-slot ( editable-slot -- )
- [ [ ref>> get-ref ] [ printer>> ] bi call ] keep
- display-slot ;
-
-: edit-slot ( editable-slot -- )
- [ clear-track ]
- [
- dup ref>> <slot-editor>
- [ 1 track-add drop ]
- [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
- ] bi ;
-
-\ editable-slot H{
- { T{ update-slot } [ update-slot ] }
- { T{ edit-slot } [ edit-slot ] }
-} set-gestures
-
-: <editable-slot> ( gadget ref -- editable-slot )
- { 1 0 } editable-slot new-track
- swap >>ref
- [ drop <gadget> ] >>printer
- [ display-slot ] keep ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.books
+ui.gadgets.packs ui.gadgets sequences models accessors kernel ;
+IN: ui.gadgets.tabbed
+
+TUPLE: tabbed-gadget < track tabs book ;
+
+: <tabbed-gadget> ( -- gadget )
+ { 0 1 } tabbed-gadget new-track
+ 0 <model> >>model
+ <shelf> >>tabs
+ dup tabs>> f track-add
+ dup model>> <empty-book> >>book
+ dup book>> 1 track-add ;
+
+: add-tab/book ( tabbed child -- tabbed )
+ [ dup book>> ] dip add-gadget drop ;
+
+: add-tab/button ( tabbed label -- tabbed )
+ [ [ dup tabs>> dup children>> length ] [ model>> ] bi ] dip
+ <toggle-button> add-gadget drop ;
+
+: add-tab ( tabbed child label -- tabbed )
+ [ add-tab/book ] [ add-tab/button ] bi* ;
--- /dev/null
+USING: help.markup help.syntax ;
+IN: ui.gadgets.tables
+
+ARTICLE: "ui.gadgets.tables" "Table gadgets"
+"The " { $vocab-link "ui.gadgets.tables" } " vocabulary implements table gadgets. Table gadgets display a grid of values, with each row's columns generated by a renderer object."
+{ $subsection table }
+"Creating new tables:"
+{ $subsection <table> } ;
+
+ABOUT: "ui.gadgets.tables"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors fry kernel math
+math.geometry.rect math.order math.vectors namespaces opengl
+sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
+ui.gadgets.worlds ui.gadgets.theme ui.gestures ui.render ui.text
+ui.gadgets.menus models math.ranges sequences combinators fonts ;
+IN: ui.gadgets.tables
+
+! Row rendererer protocol
+GENERIC: row-columns ( row renderer -- columns )
+GENERIC: row-value ( row renderer -- object )
+
+SINGLETON: trivial-renderer
+
+M: trivial-renderer row-columns drop ;
+M: object row-value drop ;
+
+TUPLE: table < gadget
+renderer filled-column column-alignment action hook
+column-widths total-width
+font text-color selection-color focus-border-color
+mouse-color column-line-color selection-required?
+selected-index selected-value
+mouse-index
+focused? ;
+
+: <table> ( rows -- table )
+ table new-gadget
+ swap >>model
+ trivial-renderer >>renderer
+ [ drop ] >>action
+ [ ] >>hook
+ f <model> >>selected-value
+ sans-serif-font >>font
+ selection-color >>selection-color
+ focus-border-color >>focus-border-color
+ dark-gray >>column-line-color
+ black >>mouse-color
+ black >>text-color ;
+
+<PRIVATE
+
+: line-height ( table -- n )
+ font>> "" text-height ;
+
+CONSTANT: table-gap 6
+
+: table-rows ( table -- rows )
+ [ control-value ] [ renderer>> ] bi '[ _ row-columns ] map ;
+
+: (compute-column-widths) ( font rows -- total widths )
+ [ drop 0 { } ] [
+ [ nip first length 0 <repetition> ] 2keep
+ [ [ text-width ] with map vmax ] with each
+ [ [ sum ] [ length 1 [-] table-gap * ] bi + ] keep
+ ] if-empty ;
+
+: compute-column-widths ( table -- total-width column-widths )
+ [ font>> ] [ table-rows ] bi (compute-column-widths) ;
+
+: update-cached-widths ( table -- )
+ dup compute-column-widths
+ [ >>total-width ] [ >>column-widths ] bi*
+ drop ;
+
+: filled-column-width ( table -- n )
+ [ dim>> first ] [ total-width>> ] bi [-] ;
+
+: update-filled-column ( table -- )
+ [ filled-column-width ]
+ [ filled-column>> ]
+ [ column-widths>> ] tri
+ 2dup empty? not and
+ [ [ + ] change-nth ] [ 3drop ] if ;
+
+M: table layout*
+ [ update-cached-widths ] [ update-filled-column ] bi ;
+
+: row-rect ( table row -- rect )
+ [ [ line-height ] dip * 0 swap 2array ]
+ [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
+
+: highlight-row ( table row color quot -- )
+ [ [ row-rect rect-bounds ] dip gl-color ] dip
+ '[ _ @ ] with-translation ; inline
+
+: draw-selected-row ( table row -- )
+ over selection-color>> [ gl-fill-rect ] highlight-row ;
+
+: draw-focused-row ( table row -- )
+ over focused?>> [
+ over focus-border-color>> [ gl-rect ] highlight-row
+ ] [ 2drop ] if ;
+
+: draw-selected ( table -- )
+ dup selected-index>> dup
+ [ [ draw-selected-row ] [ draw-focused-row ] 2bi ]
+ [ 2drop ]
+ if ;
+
+: draw-moused ( table -- )
+ dup mouse-index>> dup [
+ over mouse-color>> [ gl-rect ] highlight-row
+ ] [ 2drop ] if ;
+
+: column-offsets ( table -- xs )
+ 0 [ table-gap + + ] accumulate nip ;
+
+: column-line-offsets ( table -- xs )
+ column-offsets
+ [ f ] [ rest-slice [ table-gap 2/ - ] map ] if-empty ;
+
+: draw-columns ( table -- )
+ [ column-line-color>> gl-color ]
+ [
+ [ column-widths>> column-line-offsets ] [ dim>> second ] bi
+ '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
+ ] bi ;
+
+: y>row ( y table -- n )
+ line-height /i ;
+
+: validate-row ( m table -- n )
+ control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
+
+: visible-row ( table quot -- n )
+ '[
+ [ clip get @ origin get [ second ] bi@ - ] dip
+ y>row
+ ] keep validate-row ; inline
+
+: first-visible-row ( table -- n )
+ [ loc>> ] visible-row ;
+
+: last-visible-row ( table -- n )
+ [ rect-extent nip ] visible-row 1+ ;
+
+: column-loc ( font column width align -- loc )
+ [ [ text-width ] dip swap - ] dip
+ * 0 2array ;
+
+: draw-column ( font column width align -- )
+ over [
+ [ 2dup ] 2dip column-loc draw-text
+ ] dip table-gap + 0 2array gl-translate ;
+
+: draw-row ( columns widths align font -- )
+ '[ [ _ ] 3dip draw-column ] 3each ;
+
+: each-slice-index ( from to seq quot -- )
+ [ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
+
+: column-alignment ( table -- seq )
+ dup column-alignment>>
+ [ ] [ column-widths>> length 0 <repetition> ] ?if ;
+
+: draw-rows ( table -- )
+ {
+ [ text-color>> gl-color ]
+ [ first-visible-row ]
+ [ last-visible-row ]
+ [ control-value ]
+ [ line-height ]
+ [ renderer>> ]
+ [ column-widths>> ]
+ [ column-alignment ]
+ [ font>> ]
+ } cleave '[
+ [ 0 ] dip _ * 2array [
+ _ row-columns _ _ _ draw-row
+ ] with-translation
+ ] each-slice-index ;
+
+M: table draw-gadget*
+ dup control-value empty? [ drop ] [
+ origin get [
+ {
+ [ draw-selected ]
+ [ draw-columns ]
+ [ draw-moused ]
+ [ draw-rows ]
+ } cleave
+ ] with-translation
+ ] if ;
+
+M: table pref-dim*
+ [ compute-column-widths drop ] keep
+ [ font>> "" text-height ]
+ [ control-value length ]
+ bi * 2array ;
+
+: nth-row ( row table -- value/f ? )
+ over [ control-value nth t ] [ 2drop f f ] if ;
+
+PRIVATE>
+
+: (selected-row) ( table -- value/f ? )
+ [ selected-index>> ] keep nth-row ;
+
+: selected-row ( table -- value/f ? )
+ [ (selected-row) ] keep
+ swap [ renderer>> row-value t ] [ 2drop f f ] if ;
+
+<PRIVATE
+
+: update-selected-value ( table -- )
+ [ selected-row drop ] [ selected-value>> ] bi set-model ;
+
+: initial-selected-index ( model table -- n/f )
+ [ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ;
+
+: show-row-summary ( table n -- )
+ over nth-row
+ [ swap [ renderer>> row-value ] keep show-summary ]
+ [ 2drop ]
+ if ;
+
+M: table model-changed
+ [ nip ] [ initial-selected-index ] 2bi {
+ [ >>selected-index drop ]
+ [ show-row-summary ]
+ [ drop update-selected-value ]
+ [ drop relayout ]
+ } 2cleave ;
+
+: thin-row-rect ( table row -- rect )
+ row-rect [ { 0 1 } v* ] change-dim ;
+
+: (select-row) ( table n -- )
+ [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
+ [ >>selected-index relayout-1 ]
+ 2bi ;
+
+: mouse-row ( table -- n )
+ [ hand-rel second ] keep y>row ;
+
+: table-button-down ( table -- )
+ dup request-focus
+ dup control-value empty? [ drop ] [
+ dup [ mouse-row ] keep validate-row
+ [ >>mouse-index ] [ (select-row) ] bi
+ ] if ;
+
+PRIVATE>
+
+: row-action ( table -- )
+ dup selected-row [ swap action>> call ] [ 2drop ] if ;
+
+<PRIVATE
+
+: table-button-up ( table -- )
+ hand-click# get 2 =
+ [ row-action ] [ update-selected-value ] if ;
+
+: select-row ( table n -- )
+ over validate-row
+ [ (select-row) ]
+ [ drop update-selected-value ]
+ [ show-row-summary ]
+ 2tri ;
+
+: prev/next-row ( table n -- )
+ [ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
+
+: prev-row ( table -- )
+ -1 prev/next-row ;
+
+: next-row ( table -- )
+ 1 prev/next-row ;
+
+: first-row ( table -- )
+ 0 select-row ;
+
+: last-row ( table -- )
+ dup control-value length 1- select-row ;
+
+: hide-mouse-help ( table -- )
+ f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
+
+: valid-row? ( row table -- ? )
+ control-value length 1- 0 swap between? ;
+
+: if-mouse-row ( table true false -- )
+ [ [ mouse-row ] keep 2dup valid-row? ]
+ [ ] [ '[ nip @ ] ] tri* if ; inline
+
+: show-mouse-help ( table -- )
+ [
+ swap
+ [ >>mouse-index relayout-1 ]
+ [ show-row-summary ]
+ 2bi
+ ] [ hide-mouse-help ] if-mouse-row ;
+
+: show-table-menu ( table -- )
+ [
+ tuck [ nth-row drop ] [ renderer>> row-value ] [ hook>> ] tri
+ show-operations-menu
+ ] [ drop ] if-mouse-row ;
+
+table H{
+ { mouse-enter [ show-mouse-help ] }
+ { mouse-leave [ hide-mouse-help ] }
+ { motion [ show-mouse-help ] }
+ { T{ button-down } [ table-button-down ] }
+ { T{ button-down f f 3 } [ show-table-menu ] }
+ { T{ button-up } [ table-button-up ] }
+ { gain-focus [ t >>focused? drop ] }
+ { lose-focus [ f >>focused? drop ] }
+ { T{ drag } [ table-button-down ] }
+ { T{ key-down f f "RET" } [ row-action ] }
+ { T{ key-down f f "UP" } [ prev-row ] }
+ { T{ key-down f f "DOWN" } [ next-row ] }
+ { T{ key-down f f "HOME" } [ first-row ] }
+ { T{ key-down f f "END" } [ last-row ] }
+} set-gestures
+
+PRIVATE>
\ No newline at end of file
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2006, 2007 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors colors.gray accessors ;
+USING: arrays kernel sequences ui.gadgets ui.render
+ui.text colors colors.gray accessors ;
QUALIFIED: colors
IN: ui.gadgets.theme
: faint-boundary ( gadget -- gadget )
colors:gray solid-boundary ; inline
-: selection-color ( -- color ) light-purple ;
+: selection-color ( -- color ) light-purple ; inline
+
+: focus-border-color ( -- color ) medium-purple ; inline
: plain-gradient ( -- gradient )
{
T{ gray f 0.43 1.0 }
T{ gray f 0.5 1.0 }
} <gradient> ;
-
-: sans-serif-font { "sans-serif" plain 12 } ;
-
-: monospace-font { "monospace" plain 12 } ;
-USING: ui.gadgets ui.render ui.gestures ui.backend help.markup
-help.syntax models opengl strings ;
+USING: ui.gadgets ui.render ui.text ui.text.private
+ui.gestures ui.backend help.markup help.syntax
+models opengl opengl.sprites strings ;
IN: ui.gadgets.worlds
HELP: user-input
{ { $snippet "status" } " - a " { $link model } " holding a string to be displayed in the world's status bar." }
{ { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
{ { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
- { { $snippet "fonts" } " - a hashtable mapping font instances to vectors of " { $link sprite } " instances." }
+ { { $snippet "fonts" } " - a hashtable used by the " { $link font-renderer } "." }
{ { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
{ { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
}
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations kernel math models
-namespaces opengl sequences io combinators fry math.vectors
-ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-math.geometry.rect ;
+namespaces opengl sequences io combinators combinators.short-circuit
+fry math.vectors ui.gadgets ui.gestures ui.render ui.text ui.text.private
+ui.backend ui.gadgets.tracks math.geometry.rect ;
IN: ui.gadgets.worlds
TUPLE: world < track
M: world layout*
dup call-next-method
- dup glass>> [
- [ dup rect-dim ] dip (>>dim)
- ] when* drop ;
+ dup glass>> dup [ swap dim>> >>dim drop ] [ 2drop ] if ;
M: world focusable-child* gadget-child ;
: (draw-world) ( world -- )
dup handle>> [
- [ dup init-gl ] keep draw-gadget
+ [ init-gl ] [ draw-gadget ] [ finish-text-rendering ] tri
] with-gl-context ;
: draw-world? ( world -- ? )
#! We don't draw deactivated worlds, or those with 0 size.
#! On Windows, the latter case results in GL errors.
- [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] tri and and ;
+ { [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] } 1&& ;
TUPLE: world-error error world ;
: draw-world ( world -- )
dup draw-world? [
dup world [
- [
- (draw-world)
- ] [
+ [ (draw-world) ] [
over <world-error> ui-error
f >>active? drop
] recover
] with-variable
- ] [
- drop
- ] if ;
+ ] [ drop ] if ;
world H{
- { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
- { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
- { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
- { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
+ { T{ key-down f { C+ } "z" } [ undo-action send-action ] }
+ { T{ key-down f { C+ } "Z" } [ redo-action send-action ] }
+ { T{ key-down f { C+ } "x" } [ cut-action send-action ] }
+ { T{ key-down f { C+ } "c" } [ copy-action send-action ] }
+ { T{ key-down f { C+ } "v" } [ paste-action send-action ] }
+ { T{ key-down f { C+ } "a" } [ select-all-action send-action ] }
{ T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
{ T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
{ T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ui.gadgets kernel ;
: new-wrapper ( child class -- wrapper ) new-gadget swap add-gadget ;
-: <wrapper> ( child -- border ) wrapper new-wrapper ;
+: <wrapper> ( child -- wrapper ) wrapper new-wrapper ;
M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
HELP: motion
{ $class-description "Mouse motion gesture." }
-{ $examples { $code "T{ motion }" } } ;
+{ $examples { $code "motion" } } ;
HELP: drag
{ $class-description "Mouse drag gesture. The " { $snippet "#" } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ;
HELP: mouse-scroll
{ $class-description "Scroll wheel motion gesture. When this gesture is sent, the " { $link scroll-direction } " global variable is set to a direction vector." }
-{ $examples { $code "T{ mouse-scroll }" } } ;
+{ $examples { $code "mouse-scroll" } } ;
HELP: mouse-enter
{ $class-description "Gesture sent when the mouse enters the bounds of a gadget." }
-{ $examples { $code "T{ mouse-enter }" } } ;
+{ $examples { $code "mouse-enter" } } ;
HELP: mouse-leave
{ $class-description "Gesture sent when the mouse leaves the bounds of a gadget." }
-{ $examples { $code "T{ mouse-leave }" } } ;
+{ $examples { $code "mouse-leave" } } ;
HELP: gain-focus
{ $class-description "Gesture sent when a gadget gains keyboard focus." }
-{ $examples { $code "T{ gain-focus }" } } ;
+{ $examples { $code "gain-focus" } } ;
HELP: lose-focus
{ $class-description "Gesture sent when a gadget loses keyboard focus." }
-{ $examples { $code "T{ lose-focus }" } } ;
+{ $examples { $code "lose-focus" } } ;
HELP: cut-action
{ $class-description "Gesture sent when the " { $emphasis "cut" } " standard window system action is invoked." }
-{ $examples { $code "T{ cut-action }" } } ;
+{ $examples { $code "cut-action" } } ;
HELP: copy-action
{ $class-description "Gesture sent when the " { $emphasis "copy" } " standard window system action is invoked." }
-{ $examples { $code "T{ copy-action }" } } ;
+{ $examples { $code "copy-action" } } ;
HELP: paste-action
{ $class-description "Gesture sent when the " { $emphasis "paste" } " standard window system action is invoked." }
-{ $examples { $code "T{ paste-action }" } } ;
+{ $examples { $code "paste-action" } } ;
HELP: delete-action
{ $class-description "Gesture sent when the " { $emphasis "delete" } " standard window system action is invoked." }
-{ $examples { $code "T{ delete-action }" } } ;
+{ $examples { $code "delete-action" } } ;
HELP: select-all-action
{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
-{ $examples { $code "T{ select-all-action }" } } ;
+{ $examples { $code "select-all-action" } } ;
HELP: C+
{ $description "Control key modifier." } ;
"The following keyboard gestures, if not handled directly, send action gestures:"
{ $table
{ { $strong "Keyboard gesture" } { $strong "Action gesture" } }
- { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "T{ cut-action }" } }
- { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "T{ copy-action }" } }
- { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "T{ paste-action }" } }
- { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "T{ select-all }" } }
+ { { $snippet "T{ key-down f { C+ } \"z\" }" } { $snippet "undo-action" } }
+ { { $snippet "T{ key-down f { C+ } \"Z\" }" } { $snippet "redo-action" } }
+ { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "cut-action" } }
+ { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "copy-action" } }
+ { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "paste-action" } }
+ { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "select-all-action" } }
}
"Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ;
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables
math.parser math.vectors classes.tuple classes boxes calendar
-alarms combinators sets columns fry deques ui.gadgets ;
+alarms combinators sets columns fry deques ui.gadgets
+unicode.case combinators.short-circuit ;
IN: ui.gestures
GENERIC: handle-gesture ( gesture gadget -- ? )
M: object handle-gesture
- tuck class superclasses
- [ "gestures" word-prop ] map
- assoc-stack dup [ call f ] [ 2drop t ] if ;
+ [ nip ]
+ [ class superclasses [ "gestures" word-prop ] map assoc-stack ] 2bi
+ dup [ call f ] [ 2drop t ] if ;
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
TUPLE: propagate-gesture gesture gadget ;
+: resend-gesture ( gesture gadget -- ? )
+ [ handle-gesture ] with each-parent ;
+
M: propagate-gesture send-queued-gesture
- [ gesture>> ] [ gadget>> ] bi
- [ handle-gesture ] with each-parent drop ;
+ [ gesture>> ] [ gadget>> ] bi resend-gesture drop ;
: propagate-gesture ( gesture gadget -- )
\ propagate-gesture queue-gesture ;
'[ _ \ user-input queue-gesture ] unless-empty ;
! Gesture objects
-TUPLE: motion ; C: <motion> motion
TUPLE: drag # ; C: <drag> drag
TUPLE: button-up mods # ; C: <button-up> button-up
TUPLE: button-down mods # ; C: <button-down> button-down
-TUPLE: mouse-scroll ; C: <mouse-scroll> mouse-scroll
-TUPLE: mouse-enter ; C: <mouse-enter> mouse-enter
-TUPLE: mouse-leave ; C: <mouse-leave> mouse-leave
-TUPLE: lose-focus ; C: <lose-focus> lose-focus
-TUPLE: gain-focus ; C: <gain-focus> gain-focus
-! Higher-level actions
-TUPLE: cut-action ; C: <cut-action> cut-action
-TUPLE: copy-action ; C: <copy-action> copy-action
-TUPLE: paste-action ; C: <paste-action> paste-action
-TUPLE: delete-action ; C: <delete-action> delete-action
-TUPLE: select-all-action ; C: <select-all-action> select-all-action
+SINGLETONS:
+motion
+mouse-scroll
+mouse-enter mouse-leave
+lose-focus gain-focus ;
-TUPLE: left-action ; C: <left-action> left-action
-TUPLE: right-action ; C: <right-action> right-action
-TUPLE: up-action ; C: <up-action> up-action
-TUPLE: down-action ; C: <down-action> down-action
-
-TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
-TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
+! Higher-level actions
+SINGLETONS:
+undo-action redo-action
+cut-action copy-action paste-action
+delete-action select-all-action
+left-action right-action up-action down-action
+zoom-in-action zoom-out-action ;
! Modifiers
SYMBOLS: C+ A+ M+ S+ ;
-TUPLE: key-down mods sym ;
+TUPLE: key-gesture mods sym ;
-: <key-gesture> ( mods sym action? class -- mods' sym' )
+TUPLE: key-down < key-gesture ;
+
+: new-key-gesture ( mods sym action? class -- mods' sym' )
[ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
: <key-down> ( mods sym action? -- key-down )
- key-down <key-gesture> ;
+ key-down new-key-gesture ;
-TUPLE: key-up mods sym ;
+TUPLE: key-up < key-gesture ;
: <key-up> ( mods sym action? -- key-up )
- key-up <key-gesture> ;
+ key-up new-key-gesture ;
! Hand state
: fire-motion ( -- )
hand-buttons get-global empty? [
- T{ motion } hand-gadget get-global propagate-gesture
+ motion hand-gadget get-global propagate-gesture
] [
drag-gesture
] if ;
: hand-gestures ( new old -- )
drop-prefix <reversed>
- T{ mouse-leave } swap each-gesture
- T{ mouse-enter } swap each-gesture ;
+ mouse-leave swap each-gesture
+ mouse-enter swap each-gesture ;
: forget-rollover ( -- )
f hand-world set-global
parents hand-gestures ;
: send-lose-focus ( gadget -- )
- T{ lose-focus } swap send-gesture ;
+ lose-focus swap send-gesture ;
: send-gain-focus ( gadget -- )
- T{ gain-focus } swap send-gesture ;
+ gain-focus swap send-gesture ;
: focus-child ( child gadget ? -- )
[
: send-wheel ( direction loc world -- )
move-hand
scroll-direction set-global
- T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
+ mouse-scroll hand-gadget get-global propagate-gesture ;
: send-action ( world gesture -- )
swap world-focus propagate-gesture ;
GENERIC: gesture>string ( gesture -- string/f )
-: modifiers>string ( modifiers -- string )
- [ name>> ] map concat >string ;
+HOOK: modifiers>string os ( modifiers -- string )
+
+M: macosx modifiers>string
+ [
+ {
+ { A+ [ "⌘" ] }
+ { M+ [ "⎇" ] }
+ { S+ [ "⇧" ] }
+ { C+ [ "⌃" ] }
+ } case
+ ] map "" join ;
+
+M: object modifiers>string
+ [ name>> ] map "" join ;
M: key-down gesture>string
- dup mods>> modifiers>string
- swap sym>> append ;
+ [ mods>> ] [ sym>> ] bi
+ dup { [ length 1 = ] [ upper? ] } 1&&
+ [ [ S+ prefix ] dip ] [ >upper ] if
+ [ modifiers>string ] dip append ;
M: button-up gesture>string
[
: $operations ( element -- )
>quotation call
- f f operations>commands
+ f operations>commands
command-map. ;
: $operation ( element -- )
} ;
HELP: define-operation-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "object" object } { "hook" { $quotation "( obj -- newobj )" } ", or " { $link f } } { "translator" { $quotation "( obj -- newobj )" } ", or " { $link f } } }
-{ $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The hook quotation is applied to the target gadget; the translator quotation is applied to the result of the hook. Finally the result of the translator is passed to the operation. A distinction is drawn between the hook and the translator because for listener operations, the hook runs in the event loop and the translator runs in the listener. This avoids polluting the listener output with large prettyprinted gadgets and long quotations." } ;
+{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "object" object } { "translator" { $quotation "( obj -- newobj )" } ", or " { $link f } } }
+{ $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The translator quotation is applied to the target gadget, and the result of the translator is passed to the operation." } ;
HELP: $operations
{ $values { "element" "a sequence" } }
: my-pprint pprint ;
-[ drop t ] \ my-pprint [ ] [ ] f operation boa "op" set
+[ drop t ] \ my-pprint [ ] f operation boa "op" set
[ [ 3 my-pprint ] ] [
3 "op" get command>> command-quot
[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
-[ drop t ] \ my-pprint [ ] [ editor-string ] f operation boa
+[ drop t ] \ my-pprint [ editor-string ] f operation boa
"op" set
[ "\"4\"" ] [
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel ui.commands
-ui.gestures sequences strings math words generic namespaces make
+ui.gestures sequences strings math words generic namespaces
hashtables help.markup quotations assocs fry ;
IN: ui.operations
SYMBOL: +primary+
SYMBOL: +secondary+
-TUPLE: operation predicate command translator hook listener? ;
+TUPLE: operation predicate command translator listener? ;
: <operation> ( predicate command -- operation )
operation new
- [ ] >>hook
[ ] >>translator
swap >>command
swap >>predicate ;
: object-operations ( obj -- operations )
operations get [ predicate>> call ] with filter ;
+: gesture>operation ( gesture object -- operation/f )
+ object-operations [ operation-gesture = ] with find nip ;
+
: find-operation ( obj quot -- command )
[ object-operations ] dip find-last nip ; inline
dupd define-command <operation>
operations get push ;
-: modify-operation ( hook translator operation -- operation )
+: modify-operation ( translator operation -- operation )
clone
swap >>translator
- swap >>hook
t >>listener? ;
-: modify-operations ( operations hook translator -- operations )
- '[ [ _ _ ] dip modify-operation ] map ;
+: modify-operations ( operations translator -- operations )
+ '[ [ _ ] dip modify-operation ] map ;
-: operations>commands ( object hook translator -- pairs )
- [ object-operations ] 2dip modify-operations
+: operations>commands ( object translator -- pairs )
+ [ object-operations ] dip modify-operations
[ [ operation-gesture ] keep ] { } map>assoc ;
-: define-operation-map ( class group blurb object hook translator -- )
+: define-operation-map ( class group blurb object translator -- )
operations>commands define-command-map ;
: operation-quot ( target command -- quot )
- [
- swap literalize ,
- dup translator>> %
- command>> ,
- ] [ ] make ;
+ [ translator>> ] [ command>> ] bi '[ _ @ _ execute ] ;
M: operation invoke-command ( target command -- )
- [ hook>> call ] keep operation-quot call ;
+ operation-quot call ;
USING: ui.gadgets ui.gestures help.markup help.syntax
kernel classes strings opengl opengl.gl models
-math.geometry.rect ;
+math.geometry.rect math colors ;
IN: ui.render
HELP: gadget
{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
HELP: solid
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $snippet "color" } " slot stores a color specifier." } ;
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $snippet "color" } " slot stores an instance of " { $link color } "." }
+{ $notes "See " { $link "colors" } "." } ;
HELP: gradient
-{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $snippet "colors" } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." } ;
+{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $snippet "colors" } " slot stores a sequence of " { $link color } " instances, and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." }
+{ $notes "See " { $link "colors" } "." } ;
HELP: polygon
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
{ $list
- { { $snippet "color" } " - a color specifier" }
+ { { $snippet "color" } " - a " { $link color } }
{ { $snippet "points" } " - a sequence of points" }
}
} ;
HELP: <polygon>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "polygon" polygon } }
+{ $values { "color" color } { "points" "a sequence of points" } { "polygon" polygon } }
{ $description "Creates a new instance of " { $link polygon } "." } ;
HELP: <polygon-gadget>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "gadget" "a new " { $link gadget } } }
+{ $values { "color" color } { "points" "a sequence of points" } { "gadget" "a new " { $link gadget } } }
{ $description "Creates a gadget which is drawn as a solid filled polygon. The gadget's size is the minimum bounding box containing all the points of the polygon." } ;
-HELP: open-font
-{ $values { "font" "a font specifier" } { "open-font" object } }
-{ $description "Loads a font if it has not already been loaded, otherwise outputs the existing font." }
-{ $errors "Throws an error if the font does not exist." } ;
-
-HELP: string-width
-{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "w" "a positive integer" } }
-{ $description "Outputs the width of a string." } ;
-
-HELP: text-dim
-{ $values { "open-font" "a value output by " { $link open-font } } { "text" "a string or an array of strings" } { "dim" "a pair of integers" } }
-{ $description "Outputs the dimensions of a piece of text, which is either a single-line string or an array of lines." } ;
-
-HELP: draw-string
-{ $values { "font" "a font specifier" } { "string" string } { "loc" "a pair of integers" } }
-{ $description "Draws a line of text." } ;
-
-HELP: draw-text
-{ $values { "font" "a font specifier" } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
-{ $description "Draws text. Text is either a single-line string or an array of lines." } ;
-
ARTICLE: "gadgets-polygons" "Polygon gadgets"
"A polygon gadget renders a simple shaded polygon."
{ $subsection <polygon-gadget> }
{ $subsection polygon }
"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
-ARTICLE: "text-rendering" "Rendering text"
-"Unlike OpenGL, Factor's FreeType binding only includes the bare essentials, and there is rarely any need to directly call words in the " { $vocab-link "freetype" } " vocabulary directly. Instead, the UI provides high-level wrappers."
-$nl
-"Font objects are never constructed directly, and instead are obtained by calling a word:"
-{ $subsection open-font }
-"Measuring text:"
-{ $subsection text-dim }
-{ $subsection text-height }
-{ $subsection text-width }
-"Rendering text:"
-{ $subsection draw-string }
-{ $subsection draw-text } ;
-
ARTICLE: "ui-paint-coord" "The UI co-ordinate system"
"The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is not saved or restored when rendering a gadget. Instead, the origin of the gadget relative to the OpenGL context is stored in a variable:"
{ $subsection origin }
$nl
"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $slot "clipped?" } " slot to " { $link t } " in the gadget's constructor." ;
-ABOUT: "ui-paint-custom"
+ABOUT: "ui-paint"
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays hashtables io kernel
math namespaces opengl opengl.gl opengl.glu sequences strings
-io.styles vectors combinators math.vectors ui.gadgets colors
+vectors combinators math.vectors ui.gadgets colors
math.order math.geometry.rect locals specialized-arrays.float ;
IN: ui.render
: do-clip ( -- ) clip get flip-rect gl-set-clip ;
-: init-clip ( clip-rect rect -- )
- GL_SCISSOR_TEST glEnable
- [ rect-intersect ] keep
- dim>> dup { 0 1 } v* viewport-translation set
- { 0 0 } over gl-viewport
- 0 swap first2 0 gluOrtho2D
- clip set
+: init-clip ( clip-rect -- )
+ [
+ dim>>
+ [ { 0 1 } v* viewport-translation set ]
+ [ [ { 0 0 } ] dip gl-viewport ]
+ [ [ 0 ] dip first2 0 gluOrtho2D ] tri
+ ]
+ [ clip set ] bi
do-clip ;
-: init-gl ( clip-rect rect -- )
+: init-gl ( clip-rect -- )
GL_SMOOTH glShadeModel
+ GL_SCISSOR_TEST glEnable
GL_BLEND glEnable
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
GL_VERTEX_ARRAY glEnableClientState
:: gradient-vertices ( direction dim colors -- seq )
direction dim v* dim over v- swap
colors length dup 1- v/n [ v*n ] with map
- [ dup rot v+ 2array ] with map
+ swap [ over v+ 2array ] curry map
concat concat >float-array ;
: gradient-colors ( colors -- seq )
- [ color>raw 4array dup 2array ] map concat concat
+ [ >rgba-components 4array dup 2array ] map concat concat
>float-array ;
M: gradient recompute-pen ( gadget gradient -- )
- tuck
- [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi*
+ [ nip ] [ [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi* ] 2bi
[ gradient-vertices >>last-vertices ]
- [ gradient-colors >>last-colors ] bi
- drop ;
+ [ gradient-colors >>last-colors ]
+ bi drop ;
: draw-gradient ( colors -- )
GL_COLOR_ARRAY [
[ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
tri ;
-: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
-: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
-: arrow-down { { 0 0 } { 6 0 } { 3 6 } } ;
-: arrow-left { { 0 3 } { 6 0 } { 6 6 } } ;
-: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ;
+CONSTANT: arrow-up { { 3 0 } { 6 6 } { 0 6 } }
+CONSTANT: arrow-right { { 0 0 } { 6 3 } { 0 6 } }
+CONSTANT: arrow-down { { 0 0 } { 6 0 } { 3 6 } }
+CONSTANT: arrow-left { { 0 3 } { 6 0 } { 6 6 } }
+CONSTANT: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } }
: <polygon-gadget> ( color points -- gadget )
dup max-dim
[ <polygon> <gadget> ] dip >>dim
- swap >>interior ;
-
-! Font rendering
-SYMBOL: font-renderer
-
-HOOK: open-font font-renderer ( font -- open-font )
-
-HOOK: string-width font-renderer ( open-font string -- w )
-
-HOOK: string-height font-renderer ( open-font string -- h )
-
-HOOK: draw-string font-renderer ( font string loc -- )
-
-HOOK: x>offset font-renderer ( x open-font string -- n )
-
-HOOK: free-fonts font-renderer ( world -- )
-
-: text-height ( open-font text -- n )
- dup string? [
- string-height
- ] [
- [ string-height ] with map sum
- ] if ;
-
-: text-width ( open-font text -- n )
- dup string? [
- string-width
- ] [
- [ 0 ] 2dip [ string-width max ] with each
- ] if ;
-
-: text-dim ( open-font text -- dim )
- [ text-width ] 2keep text-height 2array ;
-
-: draw-text ( font text loc -- )
- over string? [
- draw-string
- ] [
- [
- [
- 2dup { 0 0 } draw-string
- [ open-font ] dip string-height
- 0.0 swap 0.0 glTranslated
- ] with each
- ] with-translation
- ] if ;
+ swap >>interior ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors alien core-graphics.types core-text
+core-text.fonts kernel hashtables namespaces sequences
+ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl destructors
+combinators core-foundation core-foundation.strings memoize math
+math.vectors init colors ;
+IN: ui.text.core-text
+
+SINGLETON: core-text-renderer
+
+M: core-text-renderer string-dim
+ [ " " string-dim { 0 1 } v* ] [ swap cached-line dim>> ] if-empty ;
+
+TUPLE: rendered-line line texture display-list age disposed ;
+
+: make-line-display-list ( line texture -- dlist )
+ GL_COMPILE [
+ GL_TEXTURE_2D [
+ GL_TEXTURE_BIT [
+ GL_TEXTURE_COORD_ARRAY [
+ white gl-color
+ GL_TEXTURE_2D swap glBindTexture
+ init-texture rect-texture-coords
+ dim>> fill-rect-vertices (gl-fill-rect)
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-enabled-client-state
+ ] do-attribs
+ ] do-enabled
+ ] make-dlist ;
+
+: make-core-graphics-texture ( dim bitmap -- texture )
+ GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV make-texture ;
+
+: <rendered-line> ( line -- texture )
+ #! Note: we only ref-line if make-texture and make-line-display-list
+ #! succeed
+ [
+ dup [ dim>> ] [ bitmap>> ] bi make-core-graphics-texture
+ 2dup make-line-display-list
+ 0 f \ rendered-line boa
+ ] keep ref-line ;
+
+M: rendered-line dispose*
+ [ line>> unref-line ]
+ [ texture>> delete-texture ]
+ [ display-list>> delete-dlist ] tri ;
+
+: rendered-line ( string font -- rendered-line )
+ world get fonts>>
+ [ cached-line <rendered-line> ] 2cache 0 >>age ;
+
+: age-rendered-lines ( world -- )
+ [ [ age ] age-assoc ] change-fonts drop ;
+
+M: core-text-renderer finish-text-rendering
+ age-rendered-lines age-lines ;
+
+M: core-text-renderer draw-string ( font string loc -- )
+ [
+ swap rendered-line
+ display-list>> glCallList
+ ] with-translation ;
+
+M: core-text-renderer x>offset ( x font string -- n )
+ [ 2drop 0 ] [
+ swap cached-line line>>
+ swap 0 <CGPoint> CTLineGetStringIndexForPosition
+ ] if-empty ;
+
+M: core-text-renderer offset>x ( n font string -- x )
+ swap cached-line line>> swap f
+ CTLineGetOffsetForStringIndex ;
+
+M: core-text-renderer free-fonts ( fonts -- )
+ values dispose-each ;
+
+core-text-renderer font-renderer set-global
\ No newline at end of file
--- /dev/null
+UI text rendering implementation using Mac OS X Core Text
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.syntax help.markup strings kernel alien opengl
+opengl.sprites quotations ui.render ui.text ui.text.private
+freetype ;
+IN: ui.text.freetype
+
+HELP: freetype
+{ $values { "alien" alien } }
+{ $description "Outputs a native handle used by the FreeType library, initializing FreeType first if necessary." } ;
+
+HELP: open-fonts
+{ $var-description "Global variable. Hashtable mapping font descriptors to " { $link freetype-font } " instances." } ;
+
+HELP: init-freetype
+{ $description "Initializes the FreeType library." }
+{ $notes "Do not call this word if you are using the UI." } ;
+
+HELP: freetype-font
+{ $class-description "A font which has been loaded by FreeType." } ;
+
+HELP: close-freetype
+{ $description "Closes the FreeType library." }
+{ $notes "Do not call this word if you are using the UI." } ;
+
+HELP: open-face
+{ $values { "font" freetype-font } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
+{ $description "Loads a TrueType font with the requested logical font name and style." } ;
+
+HELP: render-glyph
+{ $values { "font" freetype-font } { "char" "a non-negative integer" } { "bitmap" alien } }
+{ $description "Renders a character and outputs a pointer to the bitmap." } ;
+
+HELP: <char-sprite>
+{ $values { "font" freetype-font } { "char" "a non-negative integer" } { "sprite" sprite } }
+{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
+
+HELP: (draw-string)
+{ $values { "font" freetype-font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
+{ $description "Draws a line of text." }
+{ $notes "This is a low-level word, UI code should use " { $link draw-string } " or " { $link draw-text } " instead." }
+{ $side-effects "sprites" } ;
+
+HELP: run-char-widths
+{ $values { "font" freetype-font } { "string" string } { "widths" "a sequence of integers" } }
+{ $description "Outputs a sequence of x co-ordinates of the midpoint of each character in the string." }
+{ $notes "This word is used to convert x offsets to document locations, for example when the user moves the caret by clicking the mouse." } ;
--- /dev/null
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors alien.c-types arrays io kernel libc
+math math.vectors namespaces opengl opengl.gl opengl.sprites assocs
+sequences io.files continuations freetype
+ui.gadgets.worlds ui.text ui.text.private ui.backend
+byte-arrays accessors locals specialized-arrays.direct.uchar
+combinators.smart ;
+IN: ui.text.freetype
+
+SINGLETON: freetype-renderer
+
+SYMBOL: open-fonts
+
+: freetype-error ( n -- )
+ zero? [ "FreeType error" throw ] unless ;
+
+DEFER: freetype
+
+: init-freetype ( -- )
+ global [
+ f <void*> dup FT_Init_FreeType freetype-error
+ *void* \ freetype set
+ H{ } clone open-fonts set
+ ] bind ;
+
+: freetype ( -- alien )
+ \ freetype get-global expired? [ init-freetype ] when
+ \ freetype get-global ;
+
+TUPLE: freetype-font < identity-tuple
+ascent descent height handle widths ;
+
+M: freetype-font hashcode* drop freetype-font hashcode* ;
+
+: close-font ( font -- ) handle>> FT_Done_Face ;
+
+: close-freetype ( -- )
+ global [
+ open-fonts [ [ drop close-font ] assoc-each f ] change
+ freetype [ FT_Done_FreeType f ] change
+ ] bind ;
+
+M: freetype-renderer free-fonts ( world -- )
+ values [ second free-sprites ] each ;
+
+: ttf-name ( font -- name )
+ [ [ name>> ] [ bold?>> ] [ italic?>> ] tri ] output>array H{
+ { { "monospace" f f } "VeraMono" }
+ { { "monospace" t f } "VeraMoBd" }
+ { { "monospace" t t } "VeraMoBI" }
+ { { "monospace" f t } "VeraMoIt" }
+ { { "sans-serif" f f } "Vera" }
+ { { "sans-serif" t f } "VeraBd" }
+ { { "sans-serif" t t } "VeraBI" }
+ { { "sans-serif" f t } "VeraIt" }
+ { { "serif" f f } "VeraSe" }
+ { { "serif" t f } "VeraSeBd" }
+ { { "serif" t t } "VeraBI" }
+ { { "serif" f t } "VeraIt" }
+ } at ;
+
+: ttf-path ( name -- string )
+ "resource:fonts/" ".ttf" surround ;
+
+: (open-face) ( path length -- face )
+ #! We use FT_New_Memory_Face, not FT_New_Face, since
+ #! FT_New_Face only takes an ASCII path name and causes
+ #! problems on localized versions of Windows
+ [ freetype ] 2dip 0 f <void*> [
+ FT_New_Memory_Face freetype-error
+ ] keep *void* ;
+
+: open-face ( font -- face )
+ ttf-name ttf-path malloc-file-contents (open-face) ;
+
+SYMBOL: dpi
+
+72 dpi set-global
+
+: ft-floor ( m -- n ) -6 shift ; inline
+
+: ft-ceil ( m -- n ) 63 + -64 bitand -6 shift ; inline
+
+: font-units>pixels ( n font -- n )
+ face-size face-size-y-scale FT_MulFix ;
+
+: init-ascent ( font face -- font )
+ dup face-y-max swap font-units>pixels >>ascent ; inline
+
+: init-descent ( font face -- font )
+ dup face-y-min swap font-units>pixels >>descent ; inline
+
+: init-font ( font -- font )
+ dup handle>> init-ascent
+ dup handle>> init-descent
+ dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
+
+: set-char-size ( open-font size -- open-font )
+ [ dup handle>> 0 ] dip
+ 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
+
+: <freetype-font> ( font -- open-font )
+ freetype-font new
+ H{ } clone >>widths
+ over open-face >>handle
+ swap size>> set-char-size
+ init-font ;
+
+: open-font ( font -- open-font )
+ freetype drop open-fonts get [ <freetype-font> ] cache ;
+
+: load-glyph ( font char -- glyph )
+ [ handle>> dup ] dip 0 FT_Load_Char
+ freetype-error face-glyph ;
+
+: char-width ( open-font char -- w )
+ over widths>> [
+ dupd load-glyph glyph-hori-advance ft-ceil
+ ] cache nip ;
+
+M: freetype-renderer string-width ( font string -- w )
+ [ [ 0 ] dip open-font ] dip [ char-width + ] with each ;
+
+M: freetype-renderer string-height ( font string -- h )
+ drop open-font height>> ;
+
+: glyph-size ( glyph -- dim )
+ [ glyph-hori-advance ft-ceil ]
+ [ glyph-height ft-ceil ]
+ bi 2array ;
+
+: render-glyph ( font char -- bitmap )
+ load-glyph dup
+ FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
+
+:: copy-pixel ( i j bitmap texture -- i j )
+ 255 j texture set-nth
+ i bitmap nth j 1 + texture set-nth
+ i 1 + j 2 + ; inline
+
+:: (copy-row) ( i j bitmap texture end -- )
+ i end < [
+ i j bitmap texture copy-pixel
+ bitmap texture end (copy-row)
+ ] when ; inline recursive
+
+:: copy-row ( i j bitmap texture width width2 -- i j )
+ i j bitmap texture i width + (copy-row)
+ i width +
+ j width2 + ; inline
+
+:: copy-bitmap ( glyph texture -- )
+ [let* | bitmap [ glyph glyph-bitmap-buffer ]
+ rows [ glyph glyph-bitmap-rows ]
+ width [ glyph glyph-bitmap-width ]
+ width2 [ width next-power-of-2 2 * ] |
+ bitmap [
+ bitmap rows width * <direct-uchar-array> :> bitmap'
+ 0 0
+ rows [ bitmap' texture width width2 copy-row ] times
+ 2drop
+ ] when
+ ] ;
+
+: bitmap>texture ( glyph sprite -- id )
+ tuck dim2>> product 2 * <byte-array>
+ [ copy-bitmap ] keep [ dim2>> ] dip
+ GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE make-texture ;
+
+: glyph-texture-loc ( glyph font -- loc )
+ [ drop glyph-hori-bearing-x ft-floor ]
+ [ ascent>> swap glyph-hori-bearing-y - ft-floor ]
+ 2bi 2array ;
+
+: glyph-texture-size ( glyph -- dim )
+ [ glyph-bitmap-width next-power-of-2 ]
+ [ glyph-bitmap-rows next-power-of-2 ]
+ bi 2array ;
+
+: <char-sprite> ( open-font char -- sprite )
+ over [ render-glyph dup ] dip glyph-texture-loc
+ over glyph-size pick glyph-texture-size <sprite>
+ [ bitmap>texture ] keep [ init-sprite ] keep ;
+
+:: char-sprite ( open-font sprites char -- sprite )
+ char sprites [ open-font swap <char-sprite> ] cache ;
+
+: draw-char ( open-font sprites char loc -- )
+ GL_MODELVIEW [
+ 0 0 glTranslated
+ char-sprite dlist>> glCallList
+ ] do-matrix ;
+
+: char-widths ( open-font string -- widths )
+ [ char-width ] with { } map-as ;
+
+: scan-sums ( seq -- seq' )
+ 0 [ + ] accumulate nip ;
+
+:: (draw-string) ( open-font sprites string loc -- )
+ GL_TEXTURE_2D [
+ loc [
+ string open-font string char-widths scan-sums [
+ [ open-font sprites ] 2dip draw-char
+ ] 2each
+ ] with-translation
+ ] do-enabled ;
+
+: font-sprites ( font world -- open-font sprites )
+ fonts>> [ open-font H{ } clone 2array ] cache first2 ;
+
+M: freetype-renderer draw-string ( font string loc -- )
+ [ world get font-sprites ] 2dip (draw-string) ;
+
+: run-char-widths ( open-font string -- widths )
+ char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
+
+M: freetype-renderer x>offset ( x font string -- n )
+ [ open-font ] dip
+ [ run-char-widths [ <= ] with find drop ] keep swap
+ [ ] [ length ] ?if ;
+
+M:: freetype-renderer offset>x ( n font string -- x )
+ font open-font string n head string-width ;
+
+freetype-renderer font-renderer set-global
--- /dev/null
+UI text rendering implementation using FreeType
--- /dev/null
+unportable
--- /dev/null
+IN: ui.text
+USING: help.markup help.syntax kernel ui.text.private strings math fonts ;
+
+HELP: string-width
+{ $values { "font" font } { "string" string } { "w" "a positive integer" } }
+{ $contract "Outputs the width of a string." }
+{ $notes "This is a low-level word; use " { $link text-width } " instead." } ;
+
+HELP: text-width
+{ $values { "font" font } { "text" "a string or sequence of strings" } { "w" "a positive integer" } }
+{ $description "Outputs the width of a piece of text." } ;
+
+HELP: string-height
+{ $values { "font" font } { "string" string } { "h" "a positive integer" } }
+{ $contract "Outputs the height of a string." }
+{ $notes "This is a low-level word; use " { $link text-height } " instead." } ;
+
+HELP: text-height
+{ $values { "font" font } { "text" "a string or sequence of strings" } { "h" "a positive integer" } }
+{ $description "Outputs the height of a piece of text." } ;
+
+HELP: string-dim
+{ $values { "font" font } { "string" string } { "dim" "a pair of integers" } }
+{ $contract "Outputs the dimensions of a string." }
+{ $notes "This is a low-level word; use " { $link text-dim } " instead." } ;
+
+HELP: text-dim
+{ $values { "font" font } { "text" "a string or sequence of strings" } { "dim" "a pair of integers" } }
+{ $description "Outputs the dimensions of a piece of text, which is either a single-line string or an array of lines." } ;
+
+HELP: draw-string
+{ $values { "font" font } { "string" string } { "loc" "a pair of integers" } }
+{ $contract "Draws a line of text." } ;
+
+HELP: draw-text
+{ $values { "font" font } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
+{ $description "Draws a piece of text." } ;
+
+HELP: x>offset
+{ $values { "x" real } { "font" font } { "string" string } { "n" integer } }
+{ $contract "Outputs the string index closest to the given x co-ordinate." } ;
+
+HELP: offset>x
+{ $values { "n" integer } { "font" font } { "string" string } { "x" real } }
+{ $contract "Outputs the x co-ordinate of the character at the given index." } ;
+
+ARTICLE: "text-rendering" "Rendering text"
+"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11."
+{ $subsection "fonts" }
+"Measuring text:"
+{ $subsection text-dim }
+{ $subsection text-width }
+{ $subsection text-height }
+"Converting screen locations to string offsets, and vice versa:"
+{ $subsection x>offset }
+{ $subsection offset>x }
+"Rendering text:"
+{ $subsection draw-text }
+"Low-level text protocol for UI backends:"
+{ $subsection string-width }
+{ $subsection string-height }
+{ $subsection string-dim }
+{ $subsection draw-string } ;
+
+ABOUT: "text-rendering"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.text ;
+IN: ui.text.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays sequences math math.order opengl opengl.gl
+strings fonts colors ;
+IN: ui.text
+
+<PRIVATE
+
+SYMBOL: font-renderer
+
+HOOK: finish-text-rendering font-renderer ( world -- )
+
+M: object finish-text-rendering drop ;
+
+HOOK: string-dim font-renderer ( font string -- dim )
+
+HOOK: string-width font-renderer ( font string -- w )
+
+HOOK: string-height font-renderer ( font string -- h )
+
+M: object string-dim [ string-width ] [ string-height ] 2bi 2array ;
+
+M: object string-width string-dim first ;
+
+M: object string-height string-dim second ;
+
+HOOK: draw-string font-renderer ( font string loc -- )
+
+HOOK: free-fonts font-renderer ( world -- )
+
+: combine-text-dim ( dim1 dim2 -- dim3 )
+ [ [ first ] bi@ max ]
+ [ [ second ] bi@ + ]
+ 2bi 2array ;
+
+PRIVATE>
+
+HOOK: x>offset font-renderer ( x font string -- n )
+
+HOOK: offset>x font-renderer ( n font string -- x )
+
+GENERIC: text-dim ( font text -- dim )
+
+M: string text-dim string-dim ;
+
+M: sequence text-dim
+ [ { 0 0 } ] 2dip [ string-dim combine-text-dim ] with each ;
+
+: text-width ( font text -- w ) text-dim first ;
+
+: text-height ( font text -- h ) text-dim second ;
+
+GENERIC# draw-text 1 ( font text loc -- )
+
+M: string draw-text draw-string ;
+
+M: sequence draw-text
+ [
+ [
+ 2dup { 0 0 } draw-string
+ 0.0 swap string-height 0.0 glTranslated
+ ] with each
+ ] with-translation ;
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax ui.commands ;
+IN: ui.tools.browser
+
+ARTICLE: "ui-browser" "UI browser"
+"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or articlelink presentation is clicked. It can also be opened using words:"
+{ $subsection com-follow }
+{ $subsection browser-window }
+{ $command-map browser-gadget "toolbar" }
+{ $command-map browser-gadget "scrolling" }
+{ $command-map browser-gadget "navigation" }
+{ $command-map browser-gadget "multi-touch" }
+"Browsers are instances of " { $link browser-gadget } "." ;
+
+ABOUT: "ui-browser"
\ No newline at end of file
IN: ui.tools.browser.tests
-USING: tools.test tools.test.ui ui.tools.browser ;
+USING: tools.test tools.test.ui ui.tools.browser math ;
\ <browser-gadget> must-infer
-[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
+[ ] [ \ + <browser-gadget> [ ] with-grafted-gadget ] unit-test
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger ui.tools.workspace help help.topics kernel
-models models.history ui.commands ui.gadgets ui.gadgets.panes
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons compiler.units assocs words vocabs
-accessors fry combinators.short-circuit ;
+USING: debugger help help.topics help.crossref kernel models compiler.units
+assocs words vocabs accessors fry combinators.short-circuit
+sequences models models.history tools.apropos
+ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar
+ui.tools.common ui ;
IN: ui.tools.browser
-TUPLE: browser-gadget < track pane history ;
+TUPLE: browser-gadget < tool pane scroller search-field ;
-: show-help ( link help -- )
- history>> dup add-history
+{ 550 400 } browser-gadget set-tool-dim
+
+: show-help ( link browser-gadget -- )
+ model>> dup add-history
[ >link ] dip set-model ;
: <help-pane> ( browser-gadget -- gadget )
-
history>> [ '[ _ print-topic ] try ] <pane-control> ;
+
model>> [ '[ _ print-topic ] try ] <pane-control> ;
-: init-history ( browser-gadget -- )
- "handbook" >link <history> >>history drop ;
+: search-browser ( string browser -- )
+ '[ <apropos> _ show-help ] unless-empty ;
-: <browser-gadget> ( -- gadget )
- { 0 1 } browser-gadget new-track
- dup init-history
- add-toolbar
- dup <help-pane> >>pane
- dup pane>> <scroller> 1 track-add ;
+: <search-field> ( browser -- field )
+ '[ _ search-browser ] <action-field>
+ 10 >>min-width
+ 10 >>max-width ;
-M: browser-gadget call-tool* show-help ;
+: <browser-toolbar> ( browser -- toolbar )
+ <shelf>
+ { 5 5 } >>gap
+ over <toolbar> add-gadget
+ "Search:" <label> add-gadget
+ swap search-field>> add-gadget ;
-M: browser-gadget tool-scroller
- pane>> find-scroller ;
+: <browser-gadget> ( link -- gadget )
+ { 0 1 } browser-gadget new-track
+ swap >link <history> >>model
+ dup <search-field> >>search-field
+ dup <browser-toolbar> f track-add
+ dup <help-pane> >>pane
+ dup pane>> <scroller> >>scroller
+ dup scroller>> 1 track-add ;
M: browser-gadget graft*
[ add-definition-observer ] [ call-next-method ] bi ;
} 2|| ;
M: browser-gadget definitions-changed ( assoc browser -- )
- history>>
- dup value>> rot showing-definition?
- [ notify-connections ] [ drop ] if ;
+ model>> [ value>> swap showing-definition? ] keep
+ '[ _ notify-connections ] when ;
-: help-action ( browser-gadget -- link )
- history>> value>> >link ;
+M: browser-gadget focusable-child* search-field>> ;
-: com-follow ( link -- ) browser-gadget call-tool ;
+: (browser-window) ( topic -- )
+ <browser-gadget> "Browser" open-status-window ;
-: com-back ( browser -- ) history>> go-back ;
+: browser-window ( -- )
+ "handbook" (browser-window) ;
-: com-forward ( browser -- ) history>> go-forward ;
+\ browser-window H{ { +nullary+ t } } define-command
-: com-documentation ( browser -- ) "handbook" swap show-help ;
+: com-follow ( link -- )
+ [ browser-gadget? ] find-window
+ [ [ raise-window ] [ gadget-child show-help ] bi ]
+ [ (browser-window) ] if* ;
-: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
+: show-browser ( -- ) "handbook" com-follow ;
+
+\ show-browser H{ { +nullary+ t } } define-command
+
+: com-back ( browser -- ) model>> go-back ;
+
+: com-forward ( browser -- ) model>> go-forward ;
+
+: com-documentation ( browser -- ) "handbook" swap show-help ;
-: browser-help ( -- ) "ui-browser" help-window ;
+: browser-help ( -- ) "ui-browser" com-follow ;
\ browser-help H{ { +nullary+ t } } define-command
{ T{ key-down f { A+ } "LEFT" } com-back }
{ T{ key-down f { A+ } "RIGHT" } com-forward }
{ f com-documentation }
- { f com-vocabularies }
{ T{ key-down f f "F1" } browser-help }
} define-command-map
+: ?show-help ( link browser -- )
+ over [ show-help ] [ 2drop ] if ;
+
+: navigate ( browser quot -- )
+ '[ control-value @ ] keep ?show-help ;
+
+: com-up ( browser -- ) [ article-parent ] navigate ;
+
+: com-prev ( browser -- ) [ prev-article ] navigate ;
+
+: com-next ( browser -- ) [ next-article ] navigate ;
+
+browser-gadget "navigation" "Commands for navigating in the article hierarchy" {
+ { T{ key-down f { A+ } "u" } com-up }
+ { T{ key-down f { A+ } "p" } com-prev }
+ { T{ key-down f { A+ } "n" } com-next }
+} define-command-map
+
browser-gadget "multi-touch" f {
- { T{ left-action } com-back }
- { T{ right-action } com-forward }
+ { left-action com-back }
+ { right-action com-forward }
} define-command-map
+
+browser-gadget "scrolling"
+"The browser's scroller can be scrolled from the keyboard."
+{
+ { T{ key-down f f "UP" } com-scroll-up }
+ { T{ key-down f f "DOWN" } com-scroll-down }
+ { T{ key-down f f "PAGE_UP" } com-page-up }
+ { T{ key-down f f "PAGE_DOWN" } com-page-down }
+} define-command-map
+
+MAIN: browser-window
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs classes classes.mixin kernel namespaces
+parser ui.gadgets ui.gadgets.scrollers ui.gadgets.tracks ;
+IN: ui.tools.common
+
+SYMBOL: tool-dims
+
+tool-dims global [ H{ } clone or ] change-at
+
+TUPLE: tool < track ;
+
+M: tool pref-dim*
+ class tool-dims get at ;
+
+M: tool layout*
+ [ call-next-method ]
+ [ [ dim>> ] [ class ] bi tool-dims get set-at ]
+ bi ;
+
+: set-tool-dim ( dim class -- ) tool-dims get set-at ;
+
+SLOT: scroller
+
+: com-page-up ( tool -- )
+ scroller>> scroll-up-page ;
+
+: com-page-down ( tool -- )
+ scroller>> scroll-down-page ;
+
+: com-scroll-up ( tool -- )
+ scroller>> scroll-up-line ;
+
+: com-scroll-down ( tool -- )
+ scroller>> scroll-down-line ;
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ui.gadgets colors kernel ui.render namespaces models
-models.mapping sequences ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.labels tools.deploy.config tools.deploy.config.editor
-namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
+USING: colors kernel namespaces models tools.deploy.config
+tools.deploy.config.editor tools.deploy vocabs
+namespaces models.mapping sequences system accessors fry
+ui.gadgets ui.render ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.labels ui.gadgets.editors ui.gadgets.borders ui.gestures
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
-tools.deploy vocabs ui.tools.workspace system accessors fry ;
+ui.tools.browser ;
IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ;
: bundle-name ( parent -- parent )
- deploy-name get <field>
+ deploy-name get <model-field>
"Executable name:" label-on-left add-gadget ;
: deploy-ui ( parent -- parent )
close-window ;
: com-help ( -- )
- "ui.tools.deploy" help-window ;
+ "ui.tools.deploy" com-follow ;
\ com-help H{
{ +nullary+ t }
--- /dev/null
+USING: help.markup help.syntax ui.commands ui.gadgets.slots
+ui.gadgets.editors ;
+IN: ui.tools.inspector
+
+ARTICLE: "ui-inspector-edit" "Editing slot values in the inspector"
+"Slot values can be edited in the inspector. Clicking the ellipsis to the left of the slot's textual representation displays a slot editor gadget. A text representation of the object can be edited in the slot editor. The parser is used to turn the text representation back into an object. Keep in mind that some structure is lost in the conversion; see " { $link "prettyprint-limitations" } "."
+$nl
+"The slot editor's text editing commands are standard; see " { $link "gadgets-editors" } "."
+$nl
+"The slot editor has a toolbar containing various commands."
+{ $command-map slot-editor "toolbar" }
+"The following commands are also available."
+{ $command-map source-editor "word" } ;
+
+ARTICLE: "ui-inspector" "UI inspector"
+"The graphical inspector provides functionality similar to the terminal inspector (see " { $link "inspector" } "), adding in-place editing of slot values."
+$nl
+"To display an object in the UI inspector, right-click a presentation and choose " { $strong "Inspector" } " from the menu that appears. The inspector can also be opened from the listener using a word:"
+{ $subsection inspector }
+"The inspector embeds a table gadget, which supports keyboard navigation; see " { $link "ui.gadgets.tables" } ". It also provides a few other commands:"
+{ $command-map inspector-gadget "toolbar" }
+{ $command-map inspector-gadget "multi-touch" }
+"The UI inspector is an instance of " { $link inspector-gadget } "."
+{ $subsection "ui-inspector-edit" } ;
+
+ABOUT: "ui-inspector"
\ No newline at end of file
--- /dev/null
+IN: ui.tools.inspector.tests
+USING: tools.test ui.tools.inspector math ;
+
+\ <inspector-gadget> must-infer
+
+[ ] [ \ + <inspector-gadget> com-edit-slot ] unit-test
\ No newline at end of file
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ui.tools.workspace inspector kernel ui.commands
-ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.slots ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons namespaces ;
+USING: accessors inspector namespaces kernel models fry
+models.filter prettyprint sequences mirrors assocs classes
+io io.styles arrays hashtables math.order sorting refs fonts
+ui.tools.browser ui.commands ui.operations ui.gadgets ui.gadgets.panes
+ui.gadgets.scrollers ui.gadgets.slots ui.gadgets.tracks
+ui.gestures ui.gadgets.buttons ui.gadgets.tables
+ui.gadgets.status-bar ui.gadgets.theme ui.gadgets.labelled
+ui.tools.common ui ;
IN: ui.tools.inspector
-TUPLE: inspector-gadget < track object pane ;
+TUPLE: inspector-gadget < tool table ;
-: refresh ( inspector -- )
- [ object>> ] [ pane>> ] bi [
- +editable+ on
- +number-rows+ on
- describe
- ] with-pane ;
+{ 500 300 } inspector-gadget set-tool-dim
-: <inspector-gadget> ( -- gadget )
+TUPLE: slot-description key key-string value value-string ;
+
+: <slot-description> ( key value -- slot-description )
+ [ dup unparse-short ] bi@ slot-description boa ;
+
+SINGLETON: inspector-renderer
+
+M: inspector-renderer row-columns
+ drop [ key-string>> ] [ value-string>> ] bi 2array ;
+
+M: inspector-renderer row-value
+ drop value>> ;
+
+: <summary-gadget> ( model -- gadget )
+ [
+ standard-table-style [
+ [
+ [
+ [ "Class:" write ] with-cell
+ [ class . ] with-cell
+ ] with-row
+ ]
+ [
+ [
+ [ "Object:" write ] with-cell
+ [ short. ] with-cell
+ ] with-row
+ ]
+ [
+ [
+ [ "Summary:" write ] with-cell
+ [ summary. ] with-cell
+ ] with-row
+ ] tri
+ ] tabular-output
+ ] <pane-control> ;
+
+GENERIC: make-slot-descriptions ( obj -- seq )
+
+M: object make-slot-descriptions
+ make-mirror [ <slot-description> ] { } assoc>map ;
+
+M: hashtable make-slot-descriptions
+ call-next-method [ [ key-string>> ] compare ] sort ;
+
+: <inspector-table> ( model -- table )
+ [ make-slot-descriptions ] <filter> <table>
+ [ dup primary-operation invoke-command ] >>action
+ inspector-renderer >>renderer
+ monospace-font >>font ;
+
+: <inspector-gadget> ( obj -- gadget )
{ 0 1 } inspector-gadget new-track
add-toolbar
- <pane> >>pane
- dup pane>> <scroller> 1 track-add ;
+ swap <model> >>model
+ dup model>> <inspector-table> >>table
+ dup model>> <summary-gadget> "Object" <labelled-gadget> f track-add
+ dup table>> <scroller> "Contents" <labelled-gadget> 1 track-add ;
+
+M: inspector-gadget focusable-child*
+ table>> ;
+
+: com-refresh ( inspector -- )
+ model>> notify-connections ;
-: inspect-object ( obj mirror keys inspector -- )
- 2nip swap >>object refresh ;
+: com-push ( inspector -- obj )
+ control-value ;
-\ &push H{ { +nullary+ t } { +listener+ t } } define-command
+\ com-push H{ { +listener+ t } } define-command
-\ &back H{ { +nullary+ t } { +listener+ t } } define-command
+: slot-editor-window ( close-hook update-hook assoc key key-string -- )
+ [ <value-ref> <slot-editor> ] [ "Slot editor: " prepend ] bi*
+ open-window ;
-\ &globals H{ { +nullary+ t } { +listener+ t } } define-command
+: com-edit-slot ( inspector -- )
+ [ close-window ] swap
+ [ '[ _ com-refresh ] ]
+ [ control-value make-mirror ]
+ [ table>> (selected-row) ] tri [
+ [ key>> ] [ key-string>> ] bi
+ slot-editor-window
+ ] [ 2drop 2drop ] if ;
-: inspector-help ( -- ) "ui-inspector" help-window ;
+: inspector-help ( -- ) "ui-inspector" com-follow ;
\ inspector-help H{ { +nullary+ t } } define-command
inspector-gadget "toolbar" f {
- { T{ update-object } refresh }
- { f &push }
- { f &back }
- { f &globals }
+ { T{ update-object } com-refresh }
+ { T{ key-down f f "p" } com-push }
+ { T{ key-down f f "e" } com-edit-slot }
{ T{ key-down f f "F1" } inspector-help }
} define-command-map
inspector-gadget "multi-touch" f {
- { T{ left-action } &back }
+ { up-action com-refresh }
} define-command-map
-M: inspector-gadget tool-scroller
- pane>> find-scroller ;
+: inspector ( obj -- )
+ <inspector-gadget> "Inspector" open-status-window ;
\ No newline at end of file
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets ui.gadgets.editors listener io help.syntax
-help.markup ;
-IN: ui.tools.interactor
-
-HELP: interactor
-{ $class-description "An interactor is an " { $link editor } " intended to be used as the input component of a " { $link "ui-listener" } "."
-$nl
-"Interactors are created by calling " { $link <interactor> } "."
-$nl
-"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ;
+++ /dev/null
-IN: ui.tools.interactor.tests
-USING: ui.tools.interactor ui.gadgets.panes namespaces
-ui.gadgets.editors concurrency.promises threads listener
-tools.test kernel calendar parser accessors calendar io ;
-
-\ <interactor> must-infer
-
-[
- [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
- [ ] [ "interactor" get register-self ] unit-test
-
- [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
-
- [ ] [ <promise> "promise" set ] unit-test
-
- [
- self "interactor" get (>>thread)
- "interactor" get stream-read-quot "promise" get fulfill
- ] "Interactor test" spawn drop
-
- ! This should not throw an exception
- [ ] [ "interactor" get evaluate-input ] unit-test
-
- [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
-
- [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
-
- [ ] [ "interactor" get evaluate-input ] unit-test
-
- [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
-] with-interactive-vocabs
-
-! Hang
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
-
-[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
-
-[ ] [ 1 seconds sleep ] unit-test
-
-[ ] [ "interactor" get interactor-eof ] unit-test
-
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-: text "Hello world.\nThis is a test." ;
-
-[ ] [ text "interactor" get set-editor-string ] unit-test
-
-[ ] [ <promise> "promise" set ] unit-test
-
-[ ] [
- [
- "interactor" get register-self
- "interactor" get contents "promise" get fulfill
- ] in-thread
-] unit-test
-
-[ ] [ 100 milliseconds sleep ] unit-test
-
-[ ] [ "interactor" get evaluate-input ] unit-test
-
-[ ] [ 100 milliseconds sleep ] unit-test
-
-[ ] [ "interactor" get interactor-eof ] unit-test
-
-[ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
-
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-[ ] [ text "interactor" get set-editor-string ] unit-test
-
-[ ] [ <promise> "promise" set ] unit-test
-
-[ ] [
- [
- "interactor" get register-self
- "interactor" get stream-read1 "promise" get fulfill
- ] in-thread
-] unit-test
-
-[ ] [ 100 milliseconds sleep ] unit-test
-
-[ ] [ "interactor" get evaluate-input ] unit-test
-
-[ CHAR: H ] [ "promise" get 2 seconds ?promise-timeout ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators continuations documents
-hashtables io io.styles kernel math math.order math.vectors
-models models.delay namespaces parser lexer prettyprint
-quotations sequences strings threads listener classes.tuple
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
-ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions calendar concurrency.flags concurrency.mailboxes
-ui.tools.workspace accessors sets destructors fry vocabs.parser ;
-IN: ui.tools.interactor
-
-! If waiting is t, we're waiting for user input, and invoking
-! evaluate-input resumes the thread.
-TUPLE: interactor < source-editor
-output history flag mailbox thread waiting help ;
-
-: register-self ( interactor -- )
- <mailbox> >>mailbox
- self >>thread
- drop ;
-
-: interactor-continuation ( interactor -- continuation )
- thread>> continuation>> value>> ;
-
-: interactor-busy? ( interactor -- ? )
- #! We're busy if there's no thread to resume.
- [ waiting>> ]
- [ thread>> dup [ thread-registered? ] when ]
- bi and not ;
-
-: interactor-use ( interactor -- seq )
- dup interactor-busy? [ drop f ] [
- use swap
- interactor-continuation name>>
- assoc-stack
- ] if ;
-
-: <help-model> ( interactor -- model ) caret>> 1/3 seconds <delay> ;
-
-: <interactor> ( output -- gadget )
- interactor new-editor
- V{ } clone >>history
- <flag> >>flag
- dup <help-model> >>help
- swap >>output ;
-
-M: interactor graft*
- [ call-next-method ] [ dup help>> add-connection ] bi ;
-
-M: interactor ungraft*
- [ dup help>> remove-connection ] [ call-next-method ] bi ;
-
-: word-at-loc ( loc interactor -- word )
- over [
- [ model>> T{ one-word-elt } elt-string ] keep
- interactor-use assoc-stack
- ] [
- 2drop f
- ] if ;
-
-M: interactor model-changed
- 2dup help>> eq? [
- swap value>> over word-at-loc swap show-summary
- ] [
- call-next-method
- ] if ;
-
-: write-input ( string input -- )
- <input> presented associate
- [ H{ { font-style bold } } format ] with-nesting ;
-
-: interactor-input. ( string interactor -- )
- output>> [
- dup string? [ dup write-input nl ] [ short. ] if
- ] with-output-stream* ;
-
-: add-interactor-history ( str interactor -- )
- over empty? [ 2drop ] [ history>> adjoin ] if ;
-
-: interactor-continue ( obj interactor -- )
- mailbox>> mailbox-put ;
-
-: clear-input ( interactor -- )
- #! The with-datastack is a kludge to make it infer. Stupid.
- model>> 1array [ clear-doc ] with-datastack drop ;
-
-: interactor-finish ( interactor -- )
- [ editor-string ] keep
- [ interactor-input. ] 2keep
- [ add-interactor-history ] keep
- clear-input ;
-
-: interactor-eof ( interactor -- )
- dup interactor-busy? [
- f over interactor-continue
- ] unless drop ;
-
-: evaluate-input ( interactor -- )
- dup interactor-busy? [
- dup control-value over interactor-continue
- ] unless drop ;
-
-: interactor-yield ( interactor -- obj )
- dup thread>> self eq? [
- {
- [ t >>waiting drop ]
- [ flag>> raise-flag ]
- [ mailbox>> mailbox-get ]
- [ f >>waiting drop ]
- } cleave
- ] [ drop f ] if ;
-
-: interactor-read ( interactor -- lines )
- [ interactor-yield ] [ interactor-finish ] bi ;
-
-M: interactor stream-readln
- interactor-read dup [ first ] when ;
-
-: interactor-call ( quot interactor -- )
- dup interactor-busy? [
- 2dup interactor-input.
- 2dup interactor-continue
- ] unless 2drop ;
-
-M: interactor stream-read
- swap dup zero? [
- 2drop ""
- ] [
- [ interactor-read dup [ "\n" join ] when ] dip short head
- ] if ;
-
-M: interactor stream-read-partial
- stream-read ;
-
-M: interactor stream-read1
- dup interactor-read {
- { [ dup not ] [ 2drop f ] }
- { [ dup empty? ] [ drop stream-read1 ] }
- { [ dup first empty? ] [ 2drop CHAR: \n ] }
- [ nip first first ]
- } cond ;
-
-M: interactor dispose drop ;
-
-: go-to-error ( interactor error -- )
- [ line>> 1- ] [ column>> ] bi 2array
- over set-caret
- mark>caret ;
-
-: handle-parse-error ( interactor error -- )
- dup lexer-error? [ 2dup go-to-error error>> ] when
- swap find-workspace debugger-popup ;
-
-: try-parse ( lines interactor -- quot/error/f )
- [
- drop parse-lines-interactive
- ] [
- 2nip
- dup lexer-error? [
- dup error>> unexpected-eof? [ drop f ] when
- ] when
- ] recover ;
-
-: handle-interactive ( lines interactor -- quot/f ? )
- tuck try-parse {
- { [ dup quotation? ] [ nip t ] }
- { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
- [ handle-parse-error f f ]
- } cond ;
-
-M: interactor stream-read-quot
- [ interactor-yield ] keep {
- { [ over not ] [ drop ] }
- { [ over callable? ] [ drop ] }
- [
- [ handle-interactive ] keep swap
- [ interactor-finish ] [ nip stream-read-quot ] if
- ]
- } cond ;
-
-interactor "interactor" f {
- { T{ key-down f f "RET" } evaluate-input }
- { T{ key-down f { C+ } "k" } clear-input }
-} define-command-map
+++ /dev/null
-Interactors are used to input Factor code
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.tools.listener.completion ;
+IN: ui.tools.listener.completion.tests
+
+[ t ] [ { "USING:" "A" "B" "C" } complete-USING:? ] unit-test
+
+[ f ] [ { "USING:" "A" "B" "C" ";" } complete-USING:? ] unit-test
+
+[ t ] [ { "X" ";" "USING:" "A" "B" "C" } complete-USING:? ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs calendar colors documents
+documents.elements fry kernel words sets splitting math math.vectors
+models.delay models.filter combinators.short-circuit parser present
+sequences tools.completion generic generic.standard.engines.tuple
+fonts ui.commands ui.operations ui.gadgets ui.gadgets.editors
+ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables
+ui.gadgets.theme ui.gadgets.worlds ui.gadgets.wrappers ui.gestures
+ui.render ui.tools.listener.history ;
+IN: ui.tools.listener.completion
+
+: complete-IN:/USE:? ( tokens -- ? )
+ 2 short tail* { "IN:" "USE:" } intersects? ;
+
+: chop-; ( seq -- seq' )
+ { ";" } split1-last [ ] [ ] ?if ;
+
+: complete-USING:? ( tokens -- ? )
+ chop-; { "USING:" } intersects? ;
+
+: up-to-caret ( caret document -- string )
+ [ { 0 0 } ] 2dip doc-range ;
+
+: vocab-completion? ( interactor -- ? )
+ [ editor-caret ] [ model>> ] bi up-to-caret " \r\n" split
+ { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ;
+
+! We don't directly depend on the listener tool but we use a few slots
+SLOT: completion-popup
+SLOT: interactor
+SLOT: history
+
+TUPLE: completion-popup < wrapper table interactor element ;
+
+: find-completion-popup ( gadget -- popup )
+ [ completion-popup? ] find-parent ;
+
+SINGLETON: completion-renderer
+M: completion-renderer row-columns drop present 1array ;
+M: completion-renderer row-value drop ;
+
+: <completion-model> ( editor quot -- model )
+ [ one-word-elt <element-model> 1/3 seconds <delay> ] dip
+ '[ @ keys 1000 short head ] <filter> ;
+
+M: completion-popup hide-glass-hook
+ interactor>> f >>completion-popup request-focus ;
+
+: hide-completion-popup ( popup -- )
+ find-world hide-glass ;
+
+: completion-loc/doc ( popup -- loc doc )
+ interactor>> [ editor-caret ] [ model>> ] bi ;
+
+GENERIC: completion-string ( object -- string )
+
+M: object completion-string present ;
+
+: method-completion-string ( word -- string )
+ "method-generic" word-prop present ;
+
+M: method-body completion-string method-completion-string ;
+
+M: engine-word completion-string method-completion-string ;
+
+GENERIC# accept-completion-hook 1 ( item popup -- )
+
+: insert-completion ( item popup -- )
+ [ completion-string ] [ completion-loc/doc ] bi*
+ one-word-elt set-elt-string ;
+
+: accept-completion ( item table -- )
+ find-completion-popup
+ [ insert-completion ]
+ [ accept-completion-hook ]
+ [ nip hide-completion-popup ]
+ 2tri ;
+
+: <completion-table> ( interactor quot -- table )
+ <completion-model> <table>
+ monospace-font >>font
+ t >>selection-required?
+ completion-renderer >>renderer
+ dup '[ _ accept-completion ] >>action ;
+
+: <completion-scroller> ( object -- object )
+ <limited-scroller>
+ { 300 120 } >>min-dim
+ { 300 120 } >>max-dim ;
+
+: <completion-popup> ( interactor quot -- popup )
+ [ completion-popup new-gadget ] 2dip
+ [ drop >>interactor ] [ <completion-table> >>table ] 2bi
+ dup table>> <completion-scroller> add-gadget
+ white <solid> >>interior ;
+
+completion-popup H{
+ { T{ key-down f f "ESC" } [ hide-completion-popup ] }
+ { T{ key-down f f "TAB" } [ table>> row-action ] }
+ { T{ key-down f f " " } [ table>> row-action ] }
+} set-gestures
+
+CONSTANT: completion-popup-offset { -4 0 }
+
+: (completion-popup-loc) ( interactor element -- loc )
+ [ drop screen-loc ] [
+ [ [ [ editor-caret ] [ model>> ] bi ] dip prev-elt ] [ drop ] 2bi
+ loc>point
+ ] 2bi v+ completion-popup-offset v+ ;
+
+: completion-popup-loc-1 ( interactor element -- loc )
+ [ (completion-popup-loc) ] [ drop caret-dim ] 2bi v+ ;
+
+: completion-popup-loc-2 ( interactor element popup -- loc )
+ [ (completion-popup-loc) ] dip pref-dim { 0 1 } v* v- ;
+
+: completion-popup-fits? ( interactor element popup -- ? )
+ [ [ completion-popup-loc-1 ] dip pref-dim v+ ]
+ [ 2drop find-world dim>> ]
+ 3bi [ second ] bi@ <= ;
+
+: completion-popup-loc ( interactor element popup -- loc )
+ 3dup completion-popup-fits?
+ [ drop completion-popup-loc-1 ]
+ [ completion-popup-loc-2 ]
+ if ;
+
+: show-completion-popup ( interactor quot element -- )
+ [ nip ] [ drop <completion-popup> ] 3bi
+ [ nip >>completion-popup drop ]
+ [ [ 2drop find-world ] [ 2nip ] [ completion-popup-loc ] 3tri ] 3bi
+ show-glass ;
+
+: code-completion-popup ( interactor -- )
+ dup vocab-completion?
+ [ vocabs-matching ] [ words-matching ] ? '[ [ { } ] _ if-empty ]
+ one-word-elt show-completion-popup ;
+
+: history-matching ( interactor -- alist )
+ history>> elements>>
+ [ dup string>> { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
+ <reversed> ;
+
+: history-completion-popup ( interactor -- )
+ dup '[ drop _ history-matching ] one-line-elt show-completion-popup ;
+
+: recall-previous ( interactor -- )
+ history>> history-recall-previous ;
+
+: recall-next ( interactor -- )
+ history>> history-recall-next ;
+
+: selected-word ( editor -- word )
+ dup completion-popup>>
+ [ [ table>> selected-row drop ] [ hide-completion-popup ] bi ]
+ [ selected-token dup search [ ] [ no-word ] ?if ]
+ ?if ;
+
+: completion-gesture ( gesture completion -- value/f operation/f )
+ table>> selected-row [ tuck ] dip
+ [ gesture>operation ] [ 2drop f ] if ;
+
+M: completion-popup handle-gesture ( gesture completion -- ? )
+ 2dup completion-gesture dup [
+ [ nip find-world hide-glass ] [ invoke-command ] 2bi* f
+ ] [ 2drop call-next-method ] if ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: documents namespaces tools.test io.styles
+ui.tools.listener.history kernel ;
+IN: ui.tools.listener.history.tests
+
+[ ] [ <document> "d" set ] unit-test
+[ ] [ "d" get <history> "h" set ] unit-test
+
+[ ] [ "1" "d" get set-doc-string ] unit-test
+[ T{ input f "1" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "2" "d" get set-doc-string ] unit-test
+[ T{ input f "2" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "3" "d" get set-doc-string ] unit-test
+[ T{ input f "3" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "" "d" get set-doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "3" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "2" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "1" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "1" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-next ] unit-test
+[ "2" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "22" "d" get set-doc-string ] unit-test
+
+[ ] [ "h" get history-recall-next ] unit-test
+[ "3" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "22" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ "1" ] [ "d" get doc-string ] unit-test
+
+[ ] [ "222" "d" get set-doc-string ] unit-test
+[ T{ input f "222" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "h" get history-recall-previous ] unit-test
+[ ] [ "h" get history-recall-previous ] unit-test
+[ ] [ "h" get history-recall-previous ] unit-test
+
+[ "22" ] [ "d" get doc-string ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors documents kernel math math.order
+sequences fry io.styles ;
+IN: ui.tools.listener.history
+
+TUPLE: history document elements index ;
+
+: <history> ( document -- history )
+ V{ } clone 0 history boa ;
+
+: history-add ( history -- input )
+ dup elements>> length 1+ >>index
+ [ document>> doc-string [ <input> ] [ empty? ] bi ] keep
+ '[ [ _ elements>> push ] keep ] unless ;
+
+<PRIVATE
+
+: save-history ( history -- )
+ [ document>> doc-string ] keep
+ '[ <input> _ [ index>> ] [ elements>> ] bi set-nth ]
+ unless-empty ;
+
+: update-document ( history -- )
+ [ [ index>> ] [ elements>> ] bi nth string>> ] [ document>> ] bi
+ [ set-doc-string ] [ clear-undo drop ] 2bi ;
+
+: change-history-index ( history i -- )
+ over elements>> length 1-
+ '[ _ + _ min 0 max ] change-index drop ;
+
+: history-recall ( history i -- )
+ [ [ elements>> empty? ] keep ] dip '[
+ _
+ [ save-history ]
+ [ _ change-history-index ]
+ [ update-document ]
+ tri
+ ] unless ;
+
+PRIVATE>
+
+: history-recall-previous ( history -- )
+ -1 history-recall ;
+
+: history-recall-next ( history -- )
+ 1 history-recall ;
--- /dev/null
+USING: help.markup help.syntax ui.commands ui.operations
+ui.gadgets.editors ui.gadgets.panes listener io words ;
+IN: ui.tools.listener
+
+HELP: interactor
+{ $class-description "An interactor is an " { $link editor } " intended to be used as the input component of a " { $link "ui-listener" } "."
+$nl
+"Interactors are created by calling " { $link <interactor> } "."
+$nl
+"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ;
+
+ARTICLE: "ui-listener" "UI listener"
+"The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds an input history, and word and vocabulary completion."
+{ $command-map listener-gadget "toolbar" }
+{ $command-map interactor "completion" }
+{ $command-map interactor "interactor" }
+{ $command-map listener-gadget "scrolling" }
+{ $command-map listener-gadget "multi-touch" }
+{ $heading "Word commands" }
+"These words operate on the word at the cursor."
+{ $operations \ word }
+{ $heading "Vocabulary commands" }
+"These words operate on the vocabulary at the cursor."
+{ $operations \ word }
+{ $command-map interactor "quotation" }
+{ $heading "Editing commands" }
+"The text editing commands are standard; see " { $link "gadgets-editors" } "."
+{ $heading "Implementation" }
+"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ;
+
+ABOUT: "ui-listener"
\ No newline at end of file
-USING: continuations documents ui.tools.interactor
+USING: continuations documents
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
threads arrays generic threads accessors listener math
-calendar ;
+calendar concurrency.promises io ui.tools.common ;
IN: ui.tools.listener.tests
+\ <interactor> must-infer
+
+[
+ [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+ [ ] [ "interactor" get register-self ] unit-test
+
+ [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ <promise> "promise" set ] unit-test
+
+ [
+ self "interactor" get (>>thread)
+ "interactor" get stream-read-quot "promise" get fulfill
+ ] "Interactor test" spawn drop
+
+ ! This should not throw an exception
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+
+ [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
+] with-interactive-vocabs
+
+[
+ [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+ [ ] [ "interactor" get register-self ] unit-test
+
+ [ ] [ <promise> "promise" set ] unit-test
+
+ [
+ self "interactor" get (>>thread)
+ "interactor" get stream-readln "promise" get fulfill
+ ] "Interactor test" spawn drop
+
+ [ ] [ "hi" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ "hi" ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
+] with-interactive-vocabs
+
+! Hang
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
+
+[ ] [ 1 seconds sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+: text "Hello world.\nThis is a test." ;
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+ [
+ "interactor" get register-self
+ "interactor" get contents "promise" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 milliseconds sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ ] [ 100 milliseconds sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+ [
+ "interactor" get register-self
+ "interactor" get stream-read1 "promise" get fulfill
+ ] in-thread
+] unit-test
+
+[ ] [ 100 milliseconds sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ CHAR: H ] [ "promise" get 2 seconds ?promise-timeout ] unit-test
+
[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
[ ] [ <listener-gadget> "listener" set ] unit-test
"listener" get [
- [ "dup" ] [
- \ dup word-completion-string
- ] unit-test
-
- [ "equal?" ]
- [ \ array \ equal? method word-completion-string ] unit-test
-
<pane> <interactor> "i" set
[ t ] [ "i" get interactor? ] unit-test
[ t ] [
"i" get model>> doc-end
- "i" get editor-caret* =
+ "i" get editor-caret =
] unit-test
! Race condition discovered by SimonRC
] with-grafted-gadget
[ ] [ \ + <pane> <interactor> interactor-use use-if-necessary ] unit-test
+
+[ ] [ <listener-gadget> "l" set ] unit-test
+[ ] [ "l" get com-scroll-up ] unit-test
+[ ] [ "l" get com-scroll-down ] unit-test
+[ ] [ "l" get hide-popup ] unit-test
+[ ] [ <gadget> "l" get show-popup ] unit-test
+[ ] [ "l" get hide-popup ] unit-test
+
+[ ] [
+ <gadget> "l" get show-popup
+ <gadget> "l" get show-popup
+ "l" get hide-popup
+] unit-test
\ No newline at end of file
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: inspector help help.markup io io.styles kernel models
-namespaces parser quotations sequences vocabs words prettyprint
-listener debugger threads boxes concurrency.flags math arrays
-generic accessors combinators assocs fry ui.commands ui.gadgets
-ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
-ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
-ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
-ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
-ui.tools.interactor ui.tools.inspector ui.tools.workspace ;
+USING: accessors arrays assocs calendar combinators
+combinators.short-circuit compiler.units concurrency.flags
+concurrency.mailboxes continuations destructors documents
+documents.elements fry hashtables help help.markup io
+io.styles kernel lexer listener math models models.delay models.filter
+namespaces parser prettyprint quotations sequences strings threads
+tools.vocabs ui ui.commands ui.gadgets ui.gadgets.buttons
+ui.gadgets.editors ui.gadgets.frames ui.gadgets.grids
+ui.gadgets.labelled ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.status-bar ui.gadgets.tracks ui.gestures ui.operations
+ui.tools.browser ui.tools.common ui.tools.debugger
+ui.tools.listener.completion ui.tools.listener.history vocabs
+vocabs.parser words ;
IN: ui.tools.listener
-TUPLE: listener-gadget < track input output ;
+! If waiting is t, we're waiting for user input, and invoking
+! evaluate-input resumes the thread.
+TUPLE: interactor < source-editor
+output history flag mailbox thread waiting word-model
+completion-popup ;
+
+: register-self ( interactor -- )
+ <mailbox> >>mailbox
+ self >>thread
+ drop ;
+
+: interactor-continuation ( interactor -- continuation )
+ thread>> continuation>> value>> ;
+
+: interactor-busy? ( interactor -- ? )
+ #! We're busy if there's no thread to resume.
+ [ waiting>> ]
+ [ thread>> dup [ thread-registered? ] when ]
+ bi and not ;
+
+: interactor-use ( interactor -- seq )
+ dup interactor-busy? [ drop f ] [
+ use swap
+ interactor-continuation name>>
+ assoc-stack
+ ] if ;
+
+: <word-model> ( interactor -- model )
+ [ one-word-elt <element-model> 1/3 seconds <delay> ] keep
+ '[
+ _ dup vocab-completion?
+ [ drop >vocab-link ] [ interactor-use assoc-stack ] if
+ ] <filter> ;
+
+: <interactor> ( output -- gadget )
+ interactor new-editor
+ <flag> >>flag
+ dup <word-model> >>word-model
+ dup model>> <history> >>history
+ swap >>output ;
+
+M: interactor graft*
+ [ call-next-method ] [ dup word-model>> add-connection ] bi ;
+
+M: interactor ungraft*
+ [ dup word-model>> remove-connection ] [ call-next-method ] bi ;
+
+M: interactor model-changed
+ 2dup word-model>> eq? [
+ dup completion-popup>>
+ [ 2drop ] [ [ value>> ] dip show-summary ] if
+ ] [ call-next-method ] if ;
+
+GENERIC: (print-input) ( object -- )
+
+M: input (print-input)
+ dup presented associate
+ [ string>> H{ { font-style bold } } format ] with-nesting nl ;
+
+M: object (print-input)
+ short. ;
+
+: print-input ( object interactor -- )
+ output>> [ (print-input) ] with-output-stream* ;
+
+: interactor-continue ( obj interactor -- )
+ mailbox>> mailbox-put ;
+
+: interactor-finish ( interactor -- )
+ [ history>> history-add ] keep
+ [ print-input ]
+ [ clear-editor drop ]
+ [ model>> clear-undo drop ] 2tri ;
+
+: interactor-eof ( interactor -- )
+ dup interactor-busy? [
+ f over interactor-continue
+ ] unless drop ;
+
+: evaluate-input ( interactor -- )
+ dup interactor-busy? [ drop ] [
+ [ control-value ] keep interactor-continue
+ ] if ;
+
+: interactor-yield ( interactor -- obj )
+ dup thread>> self eq? [
+ {
+ [ t >>waiting drop ]
+ [ flag>> raise-flag ]
+ [ mailbox>> mailbox-get ]
+ [ f >>waiting drop ]
+ } cleave
+ ] [ drop f ] if ;
+
+: interactor-read ( interactor -- lines )
+ [ interactor-yield ] [ interactor-finish ] bi ;
+
+M: interactor stream-readln
+ interactor-read dup [ first ] when ;
+
+: interactor-call ( quot interactor -- )
+ dup interactor-busy? [ 2drop ] [
+ [ print-input ] [ interactor-continue ] 2bi
+ ] if ;
+
+M: interactor stream-read
+ swap dup zero? [
+ 2drop ""
+ ] [
+ [ interactor-read dup [ "\n" join ] when ] dip short head
+ ] if ;
+
+M: interactor stream-read-partial
+ stream-read ;
+
+M: interactor stream-read1
+ dup interactor-read {
+ { [ dup not ] [ 2drop f ] }
+ { [ dup empty? ] [ drop stream-read1 ] }
+ { [ dup first empty? ] [ 2drop CHAR: \n ] }
+ [ nip first first ]
+ } cond ;
+
+M: interactor dispose drop ;
+
+: go-to-error ( interactor error -- )
+ [ line>> 1- ] [ column>> ] bi 2array
+ over set-caret
+ mark>caret ;
+
+TUPLE: listener-gadget < tool input output scroller popup ;
+
+{ 550 700 } listener-gadget set-tool-dim
+
+: find-listener ( gadget -- listener )
+ [ listener-gadget? ] find-parent ;
: listener-streams ( listener -- input output )
- [ input>> ] [ output>> <pane-stream> ] bi ;
+ [ input>> ] [ output>> ] bi <pane-stream> ;
: <listener-input> ( listener -- gadget )
output>> <pane-stream> <interactor> ;
-: welcome. ( -- )
- "If this is your first time with Factor, please read the " print
- "handbook" ($link) ". To see a list of keyboard shortcuts," print
- "press F1." print nl ;
+: init-listener ( listener -- listener )
+ <scrolling-pane> >>output
+ dup <listener-input> >>input ;
-M: listener-gadget focusable-child*
- input>> ;
+: <listener-scroller> ( listener -- scroller )
+ <frame>
+ over output>> @top grid-add
+ swap input>> @center grid-add
+ <scroller> ;
-M: listener-gadget call-tool* ( input listener -- )
- [ string>> ] dip input>> set-editor-string ;
+: <listener-gadget> ( -- gadget )
+ { 0 1 } listener-gadget new-track
+ add-toolbar
+ init-listener
+ dup <listener-scroller> >>scroller
+ dup scroller>> 1 track-add ;
-M: listener-gadget tool-scroller
- output>> find-scroller ;
+M: listener-gadget focusable-child*
+ [ popup>> ] [ input>> ] bi or ;
: wait-for-listener ( listener -- )
#! Wait for the listener to start.
input>> flag>> wait-for-flag ;
-: workspace-busy? ( workspace -- ? )
- listener>> input>> interactor-busy? ;
+: listener-busy? ( listener -- ? )
+ input>> interactor-busy? ;
+
+: listener-window* ( -- listener )
+ <listener-gadget>
+ dup "Listener" open-status-window ;
+
+: listener-window ( -- )
+ [ listener-window* drop ] with-ui ;
+
+\ listener-window H{ { +nullary+ t } } define-command
+
+: (get-listener) ( quot -- listener )
+ find-window [
+ [ raise-window ]
+ [
+ gadget-child
+ [ ]
+ [ input>> scroll>caret ]
+ [ input>> request-focus ] tri
+ ] bi
+ ] [ listener-window* ] if* ; inline
+
+: get-listener ( -- listener )
+ [ listener-gadget? ] (get-listener) ;
-: listener-input ( string -- )
- get-workspace listener>> input>>
+: show-listener ( -- )
+ get-listener drop ;
+
+\ show-listener H{ { +nullary+ t } } define-command
+
+: get-ready-listener ( -- listener )
+ [
+ {
+ [ listener-gadget? ]
+ [ listener-busy? not ]
+ } 1&&
+ ] (get-listener) ;
+
+GENERIC: listener-input ( obj -- )
+
+M: input listener-input string>> listener-input ;
+
+M: string listener-input
+ get-listener input>>
[ set-editor-string ] [ request-focus ] bi ;
: (call-listener) ( quot listener -- )
input>> interactor-call ;
: call-listener ( quot -- )
- [ workspace-busy? not ] get-workspace* listener>>
+ get-ready-listener
'[ _ _ dup wait-for-listener (call-listener) ]
"Listener call" spawn drop ;
command-quot call-listener ;
M: listener-operation invoke-command ( target command -- )
- [ hook>> call ] keep operation-quot call-listener ;
+ operation-quot call-listener ;
: eval-listener ( string -- )
- get-workspace
- listener>> input>> [ set-editor-string ] keep
+ get-listener input>> [ set-editor-string ] keep
evaluate-input ;
: listener-run-files ( seq -- )
: clear-stack ( listener -- )
[ clear ] swap (call-listener) ;
-GENERIC: word-completion-string ( word -- string )
-
-M: word word-completion-string
- name>> ;
-
-M: method-body word-completion-string
- "method-generic" word-prop word-completion-string ;
-
-USE: generic.standard.engines.tuple
-
-M: engine-word word-completion-string
- "engine-generic" word-prop word-completion-string ;
-
: use-if-necessary ( word seq -- )
- over vocabulary>> over and [
+ 2dup [ vocabulary>> ] dip and [
2dup [ assoc-stack ] keep = [ 2drop ] [
[ vocabulary>> vocab-words ] dip push
] if
] [ 2drop ] if ;
-: insert-word ( word -- )
- get-workspace listener>> input>>
- [ [ word-completion-string ] dip user-input* drop ]
- [ interactor-use use-if-necessary ]
- 2bi ;
+M: word accept-completion-hook
+ interactor>> interactor-use use-if-necessary ;
-: quot-action ( interactor -- lines )
- [ control-value ] keep
- [ [ "\n" join ] dip add-interactor-history ]
- [ select-all ]
- 2bi ;
+M: object accept-completion-hook 2drop ;
-: ui-help-hook ( topic -- )
- browser-gadget call-tool ;
+: quot-action ( interactor -- lines )
+ [ history>> history-add drop ] [ control-value ] [ select-all ] tri
+ [ parse-lines ] with-compilation-unit ;
+
+: hide-popup ( listener -- )
+ dup popup>> track-remove
+ f >>popup
+ request-focus ;
+
+: show-popup ( gadget listener -- )
+ dup hide-popup
+ over >>popup
+ over f track-add drop
+ request-focus ;
+
+: show-titled-popup ( listener gadget title -- )
+ [ find-listener hide-popup ] <closable-gadget>
+ swap show-popup ;
+
+: debugger-popup ( error listener -- )
+ swap dup compute-restarts
+ [ find-listener hide-popup ] <debugger>
+ "Error" show-titled-popup ;
+
+: handle-parse-error ( interactor error -- )
+ dup lexer-error? [ 2dup go-to-error error>> ] when
+ swap find-listener debugger-popup ;
+
+: try-parse ( lines interactor -- quot/error/f )
+ [ drop parse-lines-interactive ] [
+ 2nip
+ dup lexer-error? [
+ dup error>> unexpected-eof? [ drop f ] when
+ ] when
+ ] recover ;
+
+: handle-interactive ( lines interactor -- quot/f ? )
+ [ nip ] [ try-parse ] 2bi {
+ { [ dup quotation? ] [ nip t ] }
+ { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
+ [ handle-parse-error f f ]
+ } cond ;
+
+M: interactor stream-read-quot
+ [ interactor-yield ] keep {
+ { [ over not ] [ drop ] }
+ { [ over callable? ] [ drop ] }
+ [
+ [ handle-interactive ] keep swap
+ [ interactor-finish ] [ nip stream-read-quot ] if
+ ]
+ } cond ;
+
+: pass-to-popup ( gesture interactor -- ? )
+ completion-popup>> focusable-child resend-gesture ;
+
+: interactor-operation ( gesture interactor -- ? )
+ word-model>> value>>
+ [ nip ] [ gesture>operation ] 2bi
+ dup [ invoke-command f ] [ 2drop t ] if ;
+
+M: interactor handle-gesture
+ {
+ { [ over key-gesture? not ] [ call-next-method ] }
+ { [ dup completion-popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
+ { [ dup word-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
+ [ call-next-method ]
+ } cond ;
+
+interactor "interactor" f {
+ { T{ key-down f f "RET" } evaluate-input }
+ { T{ key-down f { C+ } "k" } clear-editor }
+} define-command-map
-: ui-error-hook ( error listener -- )
- find-workspace debugger-popup ;
+interactor "completion" f {
+ { T{ key-down f f "TAB" } code-completion-popup }
+ { T{ key-down f { C+ } "p" } recall-previous }
+ { T{ key-down f { C+ } "n" } recall-next }
+ { T{ key-down f { C+ } "r" } history-completion-popup }
+} define-command-map
-: ui-inspector-hook ( obj listener -- )
- find-workspace inspector-gadget
- swap show-tool inspect-object ;
+: welcome. ( -- )
+ "If this is your first time with Factor, please read the " print
+ "handbook" ($link) ". To see a list of keyboard shortcuts," print
+ "press F1." print nl ;
: listener-thread ( listener -- )
dup listener-streams [
- [ ui-help-hook ] help-hook set
- [ '[ _ ui-error-hook ] error-hook set ]
- [ '[ _ ui-inspector-hook ] inspector-hook set ] bi
+ [ com-follow ] help-hook set
+ '[ _ debugger-popup ] error-hook set
welcome.
listener
] with-streams* ;
{
[ com-end ]
[ clear-output ]
- [ input>> clear-input ]
+ [ input>> clear-editor ]
[ start-listener-thread ]
[ wait-for-listener ]
} cleave ;
-: init-listener ( listener -- listener )
- <scrolling-pane> >>output
- dup <listener-input> >>input ;
-
-: <listener-scroller> ( listener -- scroller )
- <frame>
- over output>> @top grid-add
- swap input>> @center grid-add
- <scroller> ;
-
-: <listener-gadget> ( -- gadget )
- { 0 1 } listener-gadget new-track
- add-toolbar
- init-listener
- dup <listener-scroller> 1 track-add ;
-
-: listener-help ( -- ) "ui-listener" help-window ;
+: listener-help ( -- ) "ui-listener" com-follow ;
\ listener-help H{ { +nullary+ t } } define-command
{ T{ key-down f { C+ } "d" } com-end }
} define-command-map
-M: listener-gadget handle-gesture ( gesture gadget -- ? )
- 2dup find-workspace workspace-page handle-gesture
- [ call-next-method ] [ 2drop f ] if ;
+listener-gadget "scrolling"
+"The listener's scroller can be scrolled from the keyboard."
+{
+ { T{ key-down f { A+ } "UP" } com-scroll-up }
+ { T{ key-down f { A+ } "DOWN" } com-scroll-down }
+ { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
+ { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
+} define-command-map
+
+listener-gadget "multi-touch" f {
+ { up-action refresh-all }
+} define-command-map
+
+listener-gadget "other" f {
+ { T{ key-down f f "ESC" } hide-popup }
+} define-command-map
M: listener-gadget graft*
[ call-next-method ] [ restart-listener ] bi ;
M: listener-gadget ungraft*
- [ com-end ] [ call-next-method ] bi ;
+ [ com-end ] [ call-next-method ] bi ;
\ No newline at end of file
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations definitions ui.tools.browser
-ui.tools.interactor ui.tools.listener ui.tools.profiler
-ui.tools.search ui.tools.traceback ui.tools.workspace generic
-help.topics stack-checker summary inspector io.pathnames
-io.styles kernel namespaces parser prettyprint quotations
-tools.annotations editors tools.profiler tools.test tools.time
-tools.walker ui.commands ui.gadgets.editors ui.gestures
-ui.operations ui.tools.deploy vocabs vocabs.loader words
-sequences tools.vocabs classes compiler.units accessors
-vocabs.parser ;
+USING: continuations definitions generic help.topics threads
+stack-checker summary io.pathnames io.styles kernel namespaces
+parser prettyprint quotations tools.crossref tools.annotations
+editors tools.profiler tools.test tools.time tools.walker vocabs
+vocabs.loader words sequences tools.vocabs classes
+compiler.units accessors vocabs.parser macros.expander ui
+ui.tools.browser ui.tools.listener ui.tools.listener.completion
+ui.tools.profiler ui.tools.inspector ui.tools.traceback
+ui.commands ui.gadgets.editors ui.gestures ui.operations
+ui.tools.deploy ;
IN: ui.tools.operations
V{ } clone operations set-global
! Objects
-[ drop t ] \ inspect H{
+[ drop t ] \ inspector H{
{ +primary+ t }
- { +listener+ t }
} define-operation
: com-prettyprint ( obj -- ) . ;
{ +secondary+ t }
} define-operation
+! Thread
+: com-thread-traceback-window ( thread -- )
+ continuation>> dup occupied>>
+ [ value>> traceback-window ]
+ [ drop beep ]
+ if ;
+
+[ thread? ] \ com-thread-traceback-window H{
+ { +primary+ t }
+ { +secondary+ t }
+} define-operation
+
! Pathnames
: edit-file ( pathname -- ) edit ;
[ pathname? ] \ edit-file H{
- { +keyboard+ T{ key-down f { C+ } "E" } }
+ { +keyboard+ T{ key-down f { C+ } "e" } }
{ +primary+ t }
{ +secondary+ t }
{ +listener+ t }
UNION: definition word method-spec link vocab vocab-link ;
[ definition? ] \ edit H{
- { +keyboard+ T{ key-down f { C+ } "E" } }
+ { +keyboard+ T{ key-down f { C+ } "e" } }
{ +listener+ t }
} define-operation
[ definition? ] \ com-forget H{ } define-operation
-! Words
-[ word? ] \ insert-word H{
- { +secondary+ t }
-} define-operation
-
[ topic? ] \ com-follow H{
- { +keyboard+ T{ key-down f { C+ } "H" } }
+ { +keyboard+ T{ key-down f { C+ } "h" } }
{ +primary+ t }
} define-operation
-: com-usage ( word -- )
- get-workspace swap show-word-usage ;
-
-[ word? ] \ com-usage H{
- { +keyboard+ T{ key-down f { C+ } "U" } }
+[ word? ] \ usage. H{
+ { +keyboard+ T{ key-down f { C+ } "u" } }
+ { +listener+ t }
} define-operation
[ word? ] \ fix H{
- { +keyboard+ T{ key-down f { C+ } "F" } }
+ { +keyboard+ T{ key-down f { C+ } "f" } }
{ +listener+ t }
} define-operation
{ +listener+ t }
} define-operation
-! Vocabularies
-: com-vocab-words ( vocab -- )
- get-workspace swap show-vocab-words ;
-
-[ vocab? ] \ com-vocab-words H{
- { +secondary+ t }
- { +keyboard+ T{ key-down f { C+ } "B" } }
-} define-operation
-
: com-enter-in ( vocab -- ) vocab-name set-in ;
[ vocab? ] \ com-enter-in H{
- { +keyboard+ T{ key-down f { C+ } "I" } }
+ { +keyboard+ T{ key-down f { C+ } "i" } }
{ +listener+ t }
} define-operation
} define-operation
[ vocab-spec? ] \ run H{
- { +keyboard+ T{ key-down f { C+ } "R" } }
{ +listener+ t }
} define-operation
[ vocab? ] \ test H{
- { +keyboard+ T{ key-down f { C+ } "T" } }
{ +listener+ t }
} define-operation
{ +listener+ t }
} define-operation
-: com-show-profile ( workspace -- )
- profiler-gadget call-tool ;
-
-: com-profile ( quot -- ) profile f com-show-profile ;
+: com-profile ( quot -- ) profile profiler-window ;
[ quotation? ] \ com-profile H{
- { +keyboard+ T{ key-down f { C+ } "r" } }
+ { +keyboard+ T{ key-down f { C+ } "f" } }
{ +listener+ t }
} define-operation
-! Profiler presentations
-[ dup usage-profile? swap vocab-profile? or ]
-\ com-show-profile H{ { +primary+ t } } define-operation
+: com-expand-macros ( quot -- ) expand-macros . ;
-! Operations -> commands
-source-editor
-"word"
-"These commands operate on the Factor word named by the token at the caret position."
-\ selected-word
-[ selected-word ]
-[ dup search [ ] [ no-word ] ?if ]
-define-operation-map
+[ quotation? ] \ com-expand-macros H{
+ { +keyboard+ T{ key-down f { C+ } "m" } }
+ { +listener+ t }
+} define-operation
+! Operations -> commands
interactor
"quotation"
"These commands operate on the entire contents of the input area."
[ ]
[ quot-action ]
-[ [ parse-lines ] with-compilation-unit ]
define-operation-map
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ui.tools.workspace kernel quotations tools.profiler
-ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors fry ;
+USING: kernel quotations accessors fry
+assocs present math.order math.vectors arrays locals
+models.search models.sort models sequences vocabs
+tools.profiler words prettyprint ui ui.commands ui.gadgets
+ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
+ui.gadgets.buttons ui.gadgets.tables ui.gadgets.search-tables
+ui.gadgets.labelled ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.labels ui.gadgets.tabbed ui.gadgets.status-bar
+ui.tools.browser ui.tools.common ;
+FROM: models.filter => <filter> ;
+FROM: models.compose => <compose> ;
IN: ui.tools.profiler
-TUPLE: profiler-gadget < track pane ;
+TUPLE: profiler-gadget < tool
+sort
+vocabs vocab
+words
+methods
+generic class ;
-: <profiler-gadget> ( -- gadget )
- { 0 1 } profiler-gadget new-track
- add-toolbar
- <pane> >>pane
- dup pane>> <scroller> 1 track-add ;
+{ 700 400 } profiler-gadget set-tool-dim
+
+SINGLETONS: word-renderer vocab-renderer ;
+UNION: profiler-renderer word-renderer vocab-renderer ;
+
+! Value is a { word count } pair
+M: profiler-renderer row-columns
+ drop [ [ present ] map ] [ { "All" "" } ] if* ;
+
+M: profiler-renderer row-value
+ drop dup [ first ] when ;
+
+M: vocab-renderer row-value
+ call-next-method dup [ vocab ] when ;
+
+SINGLETON: method-renderer
+
+! Value is a { method-body count } pair
+M: method-renderer row-columns
+ drop [ first synopsis ] [ second present ] bi 2array ;
+
+M: method-renderer row-value drop first ;
+
+: <profiler-model> ( values profiler -- model )
+ [ [ filter-counts ] <filter> ] [ sort>> ] bi* <sort> ;
+
+: <words-model> ( profiler -- model )
+ [
+ [ words>> ] [ vocab>> ] bi
+ [
+ [
+ [ first vocabulary>> ]
+ [ vocab-name ]
+ bi* =
+ ] when*
+ ] <search>
+ ] keep <profiler-model> ;
+
+: match? ( pair/f str -- ? )
+ swap dup [ first present subseq? ] [ 2drop t ] if ;
+
+: <profiler-table> ( model -- table )
+ [ match? ] <search-table>
+ { 0 1 } >>column-alignment
+ 0 >>filled-column ;
+
+: <profiler-filter-model> ( counts profiler -- model' )
+ [ <model> ] dip <profiler-model> [ f prefix ] <filter> ;
-: with-profiler-pane ( gadget quot -- )
- [ pane>> ] dip with-pane ;
+: <vocabs-model> ( profiler -- model )
+ [ vocab-counters ] dip <profiler-filter-model> ;
-: com-full-profile ( gadget -- )
- [ profile. ] with-profiler-pane ;
+: <generic-model> ( profiler -- model )
+ [ generic-counters ] dip <profiler-filter-model> ;
-: com-vocabs-profile ( gadget -- )
- [ vocabs-profile. ] with-profiler-pane ;
+: <class-model> ( profiler -- model )
+ [ class-counters ] dip <profiler-filter-model> ;
-: com-method-profile ( gadget -- )
- [ method-profile. ] with-profiler-pane ;
+: method-matches? ( method generic class -- ? )
+ [ first ] 2dip
+ [ drop dup [ subwords memq? ] [ 2drop t ] if ]
+ [ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ]
+ 3bi and ;
-: profiler-help ( -- ) "ui-profiler" help-window ;
+: <methods-model> ( profiler -- model )
+ [
+ [ method-counters <model> ] dip
+ [ generic>> ] [ class>> ] bi 3array <compose>
+ [ first3 '[ _ _ method-matches? ] filter ] <filter>
+ ] keep <profiler-model> ;
+
+: sort-options ( -- alist )
+ {
+ { [ [ first ] compare ] "by name" }
+ { [ [ second ] compare invert-comparison ] "by call count" }
+ } ;
+
+: <sort-options> ( model -- gadget )
+ sort-options <radio-buttons> { 1 0 } >>orientation ;
+
+: <profiler-tool-bar> ( profiler -- gadget )
+ <shelf>
+ { 5 5 } >>gap
+ over <toolbar> add-gadget
+ "Sort by:" <label> add-gadget
+ swap sort>> <sort-options> add-gadget ;
+
+:: <words-tab> ( profiler -- gadget )
+ { 1 0 } <track>
+ profiler vocabs>> <profiler-table>
+ profiler vocab>> >>selected-value
+ vocab-renderer >>renderer
+ "Vocabularies" <labelled-gadget>
+ 1/2 track-add
+ profiler <words-model> <profiler-table>
+ word-renderer >>renderer
+ "Words" <labelled-gadget>
+ 1/2 track-add ;
+
+:: <methods-tab> ( profiler -- gadget )
+ { 0 1 } <track>
+ { 1 0 } <track>
+ profiler <generic-model> <profiler-table>
+ profiler generic>> >>selected-value
+ word-renderer >>renderer
+ "Generic words" <labelled-gadget>
+ 1/2 track-add
+ profiler <class-model> <profiler-table>
+ profiler class>> >>selected-value
+ word-renderer >>renderer
+ "Classes" <labelled-gadget>
+ 1/2 track-add
+ 1/2 track-add
+ profiler methods>> <profiler-table>
+ method-renderer >>renderer
+ "Methods" <labelled-gadget>
+ 1/2 track-add ;
+
+: <selection-model> ( -- model ) { f 0 } <model> ;
+
+: <profiler-gadget> ( -- profiler )
+ { 0 1 } profiler-gadget new-track
+ [ [ first ] compare ] <model> >>sort
+ all-words counters <model> >>words
+ <selection-model> >>vocab
+ dup <vocabs-model> >>vocabs
+ <selection-model> >>generic
+ <selection-model> >>class
+ dup <methods-model> >>methods
+ dup <profiler-tool-bar> f track-add
+ <tabbed-gadget>
+ over <words-tab> "Words" add-tab
+ over <methods-tab> "Methods" add-tab
+ 1 track-add ;
+
+: profiler-help ( -- ) "ui-profiler" com-follow ;
\ profiler-help H{ { +nullary+ t } } define-command
profiler-gadget "toolbar" f {
- { f com-full-profile }
- { f com-vocabs-profile }
- { f com-method-profile }
{ T{ key-down f f "F1" } profiler-help }
} define-command-map
-GENERIC: profiler-presentation ( obj -- quot )
-
-M: usage-profile profiler-presentation
- word>> '[ _ usage-profile. ] ;
-
-M: vocab-profile profiler-presentation
- vocab>> '[ _ vocab-profile. ] ;
-
-M: f profiler-presentation
- drop [ vocabs-profile. ] ;
+: profiler-window ( -- )
+ <profiler-gadget> "Profiling results" open-status-window ;
-M: profiler-gadget call-tool* ( obj gadget -- )
- swap profiler-presentation with-profiler-pane ;
+MAIN: profiler-window
\ No newline at end of file
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: assocs ui.tools.search help.topics io.pathnames io.styles
-kernel namespaces sequences source-files threads
-tools.test ui.gadgets ui.gestures vocabs accessors
-vocabs.loader words tools.test.ui debugger calendar ;
-IN: ui.tools.search.tests
-
-[ f ] [
- "no such word with this name exists, certainly"
- f f <definition-search>
- T{ key-down f { C+ } "x" } swap search-gesture
-] unit-test
-
-: assert-non-empty ( obj -- ) empty? f assert= ;
-
-: update-live-search ( search -- seq )
- dup [
- 300 milliseconds sleep
- list>> control-value
- ] with-grafted-gadget ;
-
-: test-live-search ( gadget quot -- ? )
- [ update-live-search dup assert-non-empty ] dip all? ;
-
-[ t ] [
- "swp" all-words f <definition-search>
- [ word? ] test-live-search
-] unit-test
-
-[ t ] [
- "" all-words t <definition-search>
- dup [
- { "set-word-prop" } over field>> set-control-value
- 300 milliseconds sleep
- search-value \ set-word-prop eq?
- ] with-grafted-gadget
-] unit-test
-
-[ t ] [
- "quot" <help-search>
- [ link? ] test-live-search
-] unit-test
-
-[ t ] [
- "factor" source-files get keys <source-file-search>
- [ pathname? ] test-live-search
-] unit-test
-
-[ t ] [
- "kern" <vocab-search>
- [ vocab-spec? ] test-live-search
-] unit-test
-
-[ t ] [
- "a" { "a" "b" "aa" } <history-search>
- [ input? ] test-live-search
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs help help.topics io.pathnames io.styles
-kernel models models.delay models.filter namespaces prettyprint
-quotations sequences sorting source-files definitions strings
-tools.completion tools.crossref classes.tuple vocabs words
-vocabs.loader tools.vocabs unicode.case calendar locals
-ui.tools.interactor ui.tools.listener ui.tools.workspace
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
-ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
-ui.gestures ui.operations ui ;
-IN: ui.tools.search
-
-TUPLE: live-search < track field list ;
-
-: search-value ( live-search -- value )
- list>> list-value ;
-
-: search-gesture ( gesture live-search -- operation/f )
- search-value object-operations
- [ operation-gesture = ] with find nip ;
-
-M: live-search handle-gesture ( gesture live-search -- ? )
- tuck search-gesture dup [
- over find-workspace hide-popup
- [ search-value ] dip invoke-command f
- ] [
- 2drop t
- ] if ;
-
-: find-live-search ( gadget -- search )
- [ live-search? ] find-parent ;
-
-: find-search-list ( gadget -- list )
- find-live-search list>> ;
-
-TUPLE: search-field < editor ;
-
-: <search-field> ( -- gadget )
- search-field new-editor ;
-
-search-field H{
- { T{ key-down f f "UP" } [ find-search-list select-previous ] }
- { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
- { T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] }
- { T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] }
- { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
-} set-gestures
-
-: <search-model> ( live-search producer -- filter )
- [
- field>> model>>
- ui-running? [ 1/5 seconds <delay> ] when
- ] dip [ "\n" join ] prepend <filter> ;
-
-: init-search-model ( live-search seq limited? -- live-search )
- [ 2drop ]
- [ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
- >>model ; inline
-
-: <search-list> ( presenter live-search -- list )
- [ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
-
-:: <live-search> ( string seq limited? presenter -- gadget )
- { 0 1 } live-search new-track
- <search-field> >>field
- seq limited? init-search-model
- presenter over <search-list> >>list
- dup field>> 1 <border> { 1 1 } >>fill f track-add
- dup list>> <scroller> 1 track-add
- string over field>> set-editor-string
- dup field>> end-of-document ;
-
-M: live-search focusable-child* field>> ;
-
-M: live-search pref-dim* drop { 400 200 } ;
-
-: current-word ( workspace -- string )
- listener>> input>> selected-word ;
-
-: definition-candidates ( words -- candidates )
- [ dup synopsis >lower ] { } map>assoc sort-values ;
-
-: <definition-search> ( string words limited? -- gadget )
- [ definition-candidates ] dip [ synopsis ] <live-search> ;
-
-: word-candidates ( words -- candidates )
- [ dup name>> >lower ] { } map>assoc ;
-
-: <word-search> ( string words limited? -- gadget )
- [ word-candidates ] dip [ synopsis ] <live-search> ;
-
-: com-words ( workspace -- )
- dup current-word all-words t <word-search>
- "Word search" show-titled-popup ;
-
-: show-vocab-words ( workspace vocab -- )
- [ "" swap words natural-sort f <word-search> ]
- [ "Words in " swap vocab-name append ]
- bi show-titled-popup ;
-
-: show-word-usage ( workspace word -- )
- [ "" swap smart-usage f <definition-search> ]
- [ "Words and methods using " swap name>> append ]
- bi show-titled-popup ;
-
-: help-candidates ( seq -- candidates )
- [ dup >link swap article-title >lower ] { } map>assoc
- sort-values ;
-
-: <help-search> ( string -- gadget )
- all-articles help-candidates
- f [ article-title ] <live-search> ;
-
-: com-search ( workspace -- )
- "" <help-search> "Help search" show-titled-popup ;
-
-: source-file-candidates ( seq -- candidates )
- [ dup <pathname> swap >lower ] { } map>assoc ;
-
-: <source-file-search> ( string files -- gadget )
- source-file-candidates
- f [ string>> ] <live-search> ;
-
-: all-source-files ( -- seq )
- source-files get keys natural-sort ;
-
-: com-sources ( workspace -- )
- "" all-source-files <source-file-search>
- "Source file search" show-titled-popup ;
-
-: show-vocab-files ( workspace vocab -- )
- [ "" swap vocab-files <source-file-search> ]
- [ "Source files in " swap vocab-name append ]
- bi show-titled-popup ;
-
-: vocab-candidates ( -- candidates )
- all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
-
-: <vocab-search> ( string -- gadget )
- vocab-candidates f [ vocab-name ] <live-search> ;
-
-: com-vocabs ( workspace -- )
- dup current-word <vocab-search>
- "Vocabulary search" show-titled-popup ;
-
-: history-candidates ( seq -- candidates )
- [ dup <input> swap >lower ] { } map>assoc ;
-
-: <history-search> ( string seq -- gadget )
- history-candidates
- f [ string>> ] <live-search> ;
-
-: listener-history ( listener -- seq )
- input>> history>> <reversed> ;
-
-: com-history ( workspace -- )
- "" over listener>> listener-history <history-search>
- "History search" show-titled-popup ;
-
-workspace "toolbar" f {
- { T{ key-down f { C+ } "p" } com-history }
- { T{ key-down f f "TAB" } com-words }
- { T{ key-down f { C+ } "u" } com-vocabs }
- { T{ key-down f { C+ } "e" } com-sources }
- { T{ key-down f { C+ } "h" } com-search }
-} define-command-map
+++ /dev/null
-Support for graphical completion popups
-USING: editors help.markup help.syntax summary inspector io
-io.styles listener parser prettyprint tools.profiler
-tools.walker ui.commands ui.gadgets.editors ui.gadgets.panes
-ui.gadgets.presentations ui.gadgets.slots ui.operations
-ui.tools.browser ui.tools.interactor ui.tools.inspector
-ui.tools.listener ui.tools.operations ui.tools.profiler
-ui.tools.walker ui.tools.workspace vocabs ;
+USING: editors help.markup help.syntax summary inspector io io.styles
+listener parser prettyprint tools.profiler tools.walker ui.commands
+ui.gadgets.panes ui.gadgets.presentations ui.operations
+ui.tools.operations ui.tools.profiler ui.tools.common vocabs ;
IN: ui.tools
+ARTICLE: "starting-ui-tools" "Starting the UI tools"
+"The UI tools start automatically where possible:"
+{ $list
+ { "On Windows, the tools start when the Factor executable is run." }
+ { "On X11, the tools start if the " { $snippet "DISPLAY" } " environment variable is set." }
+ { "On Mac OS X, the tools start if the " { $snippet "Factor.app" } " application bundle is run." }
+}
+"In all cases, passing the " { $snippet "-run=listener" } " command line switch starts the terminal listener instead. The UI can be started from the terminal by issuing the following command:"
+{ $code "USE: threads" "[ \"ui.tools\" run ] in-thread" } ;
+
+ARTICLE: "ui-shortcuts" "UI tool keyboard shortcuts"
+"Every UI tool has its own set of keyboard shortcuts; press " { $snippet "F1" } " inside a tool to see help. Some common shortcuts are also supported by all tools:"
+{ $command-map tool "tool-switching" }
+{ $command-map tool "common" } ;
+
ARTICLE: "ui-presentations" "Presentations in the UI"
"A " { $emphasis "presentation" } " is a graphical view of an object which is directly linked to the object in some way. The help article links you see in the documentation browser are presentations; and if you " { $link see } " a word in the UI listener, all words in the definition will themselves be presentations."
$nl
$nl
"Clicking and holding the right mouse button on a presentation displays a popup menu listing available operations."
$nl
-"Presentation gadgets can be constructed directly using the " { $link <presentation> } " word, and they can also be written to " { $link pane } " gadgets using the " { $link write-object } " word." ;
-
-ARTICLE: "ui-listener" "UI listener"
-"The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds the following features:"
-{ $list
- "Input history"
- { "Completion (see " { $link "ui-completion" } ")" }
- { "Clickable presentations (see " { $link "ui-presentations" } ")" }
-}
-{ $command-map listener-gadget "toolbar" }
-{ $command-map interactor "interactor" }
-{ $command-map source-editor "word" }
-{ $command-map interactor "quotation" }
-{ $heading "Editing commands" }
-"The text editing commands are standard; see " { $link "gadgets-editors" } "."
-{ $heading "Implementation" }
-"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } ")." ;
-
-ARTICLE: "ui-inspector" "UI inspector"
-"The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."
-$nl
-"To display an object in the UI inspector, use the " { $link inspect } " word from the UI listener, or right-click a presentation and choose " { $strong "Inspect" } " from the menu that appears."
-$nl
-"When the UI inspector is running, all of the terminal inspector words are available, such as " { $link &at } " and " { $link &put } ". Changing slot values using terminal inspector words automatically updates the UI inspector display."
-$nl
-"Slots can also be edited graphically. Clicking the ellipsis to the left of the slot's textual representation displays a slot editor gadget. A text representation of the object can be edited in the slot editor. The parser is used to turn the text representation back into an object. Keep in mind that some structure is lost in the conversion; see " { $link "prettyprint-limitations" } "."
-$nl
-"The slot editor's text editing commands are standard; see " { $link "gadgets-editors" } "."
-$nl
-"The slot editor has a toolbar containing various commands."
-{ $command-map slot-editor "toolbar" }
-{ $command-map inspector-gadget "multi-touch" }
-"The following commands are also available."
-{ $command-map source-editor "word" } ;
-
-ARTICLE: "ui-browser" "UI browser"
-"The browser is used to display Factor code, documentation, and vocabularies."
-{ $command-map browser-gadget "toolbar" }
-{ $command-map browser-gadget "multi-touch" }
-"Browsers are instances of " { $link browser-gadget } "." ;
+"For more about presentation gadgets, see " { $link "ui.gadgets.presentations" } "." ;
ARTICLE: "ui-profiler" "UI profiler"
"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
$nl
"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
$nl
-"Vocabulary and word presentations in the profiler pane can be clicked on to show profiler results pertaining to the object in question. Clicking a vocabulary in the profiler yields the same output as the " { $link vocab-profile. } " word, and clicking a word yields the same output as the " { $link usage-profile. } " word. Consult " { $link "profiling" } " for details."
-{ $command-map profiler-gadget "toolbar" } ;
+"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring."
+$nl
+"Consult " { $link "profiling" } " for details about the profiler itself."
+{ $command-map profiler-gadget "toolbar" }
+"The profiler is an instance of " { $link profiler-gadget } "." ;
ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X"
"On Mac OS X, the Factor UI offers additional features which integrate with this operating system."
;
-ARTICLE: "ui-completion-words" "Word completion popup"
-"Clicking a word in the word completion popup displays the word definition in the " { $link "ui-browser" } ". Pressing " { $snippet "RET" } " with a word selected inserts the word name in the listener, along with a " { $link POSTPONE: USE: } " declaration (if necessary)."
-{ $operations \ $operations } ;
-
-ARTICLE: "ui-completion-vocabs" "Vocabulary completion popup"
-"Clicking a vocabulary in the vocabulary completion popup displays a list of words in the vocabulary in another " { $link "ui-completion-words" } ". Pressing " { $snippet "RET" } " adds the vocabulary to the current search path, just as if you invoked " { $link POSTPONE: USE: } "."
-{ $operations "kernel" vocab } ;
-
-ARTICLE: "ui-completion-sources" "Source file completion popup"
-"The source file completion popup lists all source files which have been previously loaded by " { $link run-file } ". Clicking a source file or pressing " { $snippet "RET" } " opens the source file in your editor with " { $link edit } "."
-{ $operations P" " } ;
-
-ARTICLE: "ui-completion" "UI completion popups"
-"Completion popups allow fast access to aspects of the environment. Completion popups can be invoked by clicking the row of buttons along the bottom of the workspace, or via keyboard commands:"
-{ $command-map workspace "toolbar" }
-"A completion popup instantly updates the list of completions as keys are typed. The list of completions can be navigated from the keyboard with the " { $snippet "UP" } " and " { $snippet "DOWN" } " arrow keys. Every completion has a " { $emphasis "primary action" } " and " { $emphasis "secondary action" } ". The primary action is invoked when clicking a completion, and the secondary action is invoked on the currently-selected completion when pressing " { $snippet "RET" } "."
-$nl
-"The primary and secondary actions, along with additional keyboard shortcuts, are documented for some completion popups in the below sections."
-{ $subsection "ui-completion-words" }
-{ $subsection "ui-completion-vocabs" }
-{ $subsection "ui-completion-sources" } ;
-
-ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
-"See " { $link "gesture-differences" } " to find out how your platform's modifier keys map to modifiers in the Factor UI."
-{ $command-map workspace "tool-switching" }
-{ $command-map workspace "scrolling" }
-{ $command-map workspace "workflow" }
-{ $command-map workspace "multi-touch" } ;
-
ARTICLE: "ui-tools" "UI developer tools"
-"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
+"The " { $vocab-link "ui.tools" } " vocabulary hierarchy implements a collection of simple developer tools."
$nl
-"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
-{ $subsection "ui-workspace-keys" }
+"To take full advantage of the UI tools, you should be using a supported text editor. See " { $link "editor" } "."
+{ $subsection "ui-shortcuts" }
{ $subsection "ui-presentations" }
-{ $subsection "ui-completion" }
-{ $heading "Tools" }
-"A single-window " { $emphasis "workspace" } " contains the most frequently-used tools:"
{ $subsection "ui-listener" }
{ $subsection "ui-browser" }
{ $subsection "ui-inspector" }
{ $subsection "ui-profiler" }
-"Additional tools:"
{ $subsection "ui-walker" }
{ $subsection "ui.tools.deploy" }
"Platform-specific features:"
+++ /dev/null
-USING: ui.tools ui.tools.interactor ui.tools.listener
-ui.tools.search ui.tools.workspace kernel models namespaces
-sequences tools.test ui.gadgets ui.gadgets.buttons
-ui.gadgets.labelled ui.gadgets.presentations
-ui.gadgets.menus ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
-IN: ui.tools.tests
-
-[ f ]
-[
- <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
-] unit-test
-
-[ ] [ <workspace> "w" set ] unit-test
-[ ] [ "w" get com-scroll-up ] unit-test
-[ ] [ "w" get com-scroll-down ] unit-test
-[ t ] [
- "w" get book>> children>>
- [ tool-scroller ] map sift [ scroller? ] all?
-] unit-test
-[ ] [ "w" get hide-popup ] unit-test
-[ ] [ <gadget> "w" get show-popup ] unit-test
-[ ] [ "w" get hide-popup ] unit-test
-
-[ ] [
- <gadget> "w" get show-popup
- <gadget> "w" get show-popup
- "w" get hide-popup
-] unit-test
-
-[ ] [ <workspace> [ ] with-grafted-gadget ] unit-test
-
-"w" get [
-
- [ ] [ "w" get "kernel" vocab show-vocab-words ] unit-test
-
- [ ] [ notify-queued ] unit-test
-
- [ ] [ "w" get popup>> content>>
- list>> gadget-child "p" set ] unit-test
-
- [ t ] [ "p" get presentation? ] unit-test
-
- [ ] [
- "p" get [ object>> ] [ dup hook>> curry ] bi
- <operations-menu> gadget-child gadget-child "c" set
- ] unit-test
-
- [ ] [ notify-queued ] unit-test
-
- [ t ] [ "c" get button? ] unit-test
-
- [ ] [
- "w" get listener>> input>>
- 3 handle-parse-error
- ] unit-test
-
- [ ] [ notify-queued ] unit-test
-] with-grafted-gadget
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs debugger ui.tools.workspace
-ui.tools.operations ui.tools.traceback ui.tools.browser
-ui.tools.inspector ui.tools.listener ui.tools.profiler
-ui.tools.operations inspector io kernel math models namespaces
-prettyprint quotations sequences ui ui.commands ui.gadgets
-ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
-ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
-ui.gadgets.presentations ui.gestures words vocabs.loader
-tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
-mirrors fry ;
+USING: memory system kernel tools.vocabs ui.tools.operations
+ui.tools.listener ui.tools.browser ui.tools.common ui.commands
+ui.gestures ui ;
IN: ui.tools
-: <workspace-tabs> ( workspace -- tabs )
- model>>
- "tool-switching" workspace command-map commands>>
- [ command-string ] { } assoc>map <enum> >alist
- <toggle-buttons> ;
+: main ( -- )
+ restore-windows? [ restore-windows ] [ listener-window ] if ;
-: <workspace-book> ( workspace -- gadget )
- <gadget>
- <browser-gadget>
- <inspector-gadget>
- <profiler-gadget>
- 4array
- swap model>> <book> ;
-
-: <workspace> ( -- workspace )
- { 0 1 } workspace new-track
- 0 <model> >>model
- <listener-gadget> >>listener
- dup <workspace-book> >>book
+MAIN: main
- dup <workspace-tabs> f track-add
- dup book>> 0 track-add
- dup listener>> 1 track-add
- add-toolbar ;
+\ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command
-: resize-workspace ( workspace -- )
- dup sizes>> over control-value 0 = [
- 0 over set-second
- 1 swap set-third
- ] [
- 2/3 over set-second
- 1/3 swap set-third
- ] if relayout ;
+\ save H{ { +nullary+ t } } define-command
-M: workspace model-changed
- nip
- dup listener>> output>> scroll>bottom
- dup resize-workspace
- request-focus ;
+: com-exit ( -- ) 0 exit ;
-[ workspace-window ] ui-hook set-global
+\ com-exit H{ { +nullary+ t } } define-command
-: select-tool ( workspace n -- ) swap book>> model>> set-model ;
-
-: com-listener ( workspace -- ) 0 select-tool ;
-
-: com-browser ( workspace -- ) 1 select-tool ;
-
-: com-inspector ( workspace -- ) 2 select-tool ;
-
-: com-profiler ( workspace -- ) 3 select-tool ;
-
-workspace "tool-switching" f {
- { T{ key-down f { A+ } "1" } com-listener }
- { T{ key-down f { A+ } "2" } com-browser }
- { T{ key-down f { A+ } "3" } com-inspector }
- { T{ key-down f { A+ } "4" } com-profiler }
-} define-command-map
-
-workspace "multi-touch" f {
- { T{ zoom-out-action } com-listener }
- { T{ up-action } refresh-all }
+tool "tool-switching" f {
+ { T{ key-down f { A+ } "l" } show-listener }
+ { T{ key-down f { A+ } "L" } listener-window }
+ { T{ key-down f { A+ } "b" } show-browser }
+ { T{ key-down f { A+ } "B" } browser-window }
} define-command-map
-\ workspace-window
-H{ { +nullary+ t } } define-command
-
-\ refresh-all
-H{ { +nullary+ t } { +listener+ t } } define-command
-
-workspace "workflow" f {
- { T{ key-down f { C+ } "n" } workspace-window }
- { T{ key-down f f "ESC" } hide-popup }
+tool "common" f {
+ { T{ key-down f { A+ } "s" } save }
+ { T{ key-down f { A+ } "w" } close-window }
+ { T{ key-down f { A+ } "q" } com-exit }
{ T{ key-down f f "F2" } refresh-all }
-} define-command-map
-
-[
- <workspace> dup "Factor workspace" open-status-window
-] workspace-window-hook set-global
-
-: inspect-continuation ( traceback -- )
- control-value '[ _ inspect ] call-listener ;
-
-traceback-gadget "toolbar" f {
- { T{ key-down f f "v" } variables }
- { T{ key-down f f "n" } inspect-continuation }
-} define-command-map
+} define-command-map
\ No newline at end of file
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel models namespaces
- prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
- ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
- ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
- hashtables inspector ;
-
+prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
+ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
+ui.gadgets.status-bar ui.gadgets.scrollers ui.tools.inspector
+ui.gestures sequences hashtables inspector ;
IN: ui.tools.traceback
: <callstack-display> ( model -- gadget )
: traceback-window ( continuation -- )
<model> <traceback-gadget> "Traceback" open-status-window ;
+
+: inspect-continuation ( traceback -- )
+ control-value inspector ;
+
+traceback-gadget "toolbar" f {
+ { T{ key-down f f "v" } variables }
+ { T{ key-down f f "n" } inspect-continuation }
+} define-command-map
\ No newline at end of file
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel concurrency.messaging inspector
ui.tools.listener ui.tools.traceback ui.gadgets.buttons
ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
-models models.filter ui.tools.workspace ui.gestures
+models models.filter ui.tools.browser ui.tools.common ui.gestures
ui.gadgets.labels ui threads namespaces make tools.walker assocs
combinators fry ;
IN: ui.tools.walker
-TUPLE: walker-gadget < track
+TUPLE: walker-gadget < tool
status continuation thread
traceback
closing? ;
+{ 620 620 } walker-gadget set-tool-dim
+
: walker-command ( walker msg -- )
swap
dup thread>> thread-registered?
dup status>> self <thread-status> f track-add
dup traceback>> 1 track-add ;
-: walker-help ( -- ) "ui-walker" help-window ;
+: walker-help ( -- ) "ui-walker" com-follow ;
\ walker-help H{ { +nullary+ t } } define-command
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Graphical development environment
+++ /dev/null
-IN: ui.tools.workspace.tests
-USING: tools.test ui.tools ;
-
-\ <workspace> must-infer
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes continuations help help.topics kernel models
-sequences assocs arrays namespaces accessors math.vectors fry ui
-ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
-ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
-ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
-ui.gadgets.presentations ui.gadgets.status-bar ui.commands
-ui.gestures ;
-IN: ui.tools.workspace
-
-TUPLE: workspace < track book listener popup ;
-
-: find-workspace ( gadget -- workspace ) [ workspace? ] find-parent ;
-
-SYMBOL: workspace-window-hook
-
-: workspace-window* ( -- workspace ) workspace-window-hook get call ;
-
-: workspace-window ( -- ) workspace-window* drop ;
-
-GENERIC: call-tool* ( arg tool -- )
-
-GENERIC: tool-scroller ( tool -- scroller )
-
-M: gadget tool-scroller drop f ;
-
-: find-tool ( class workspace -- index tool )
- book>> children>> [ class eq? ] with find ;
-
-: show-tool ( class workspace -- tool )
- [ find-tool swap ] keep book>> model>>
- set-model ;
-
-: get-workspace* ( quot -- workspace )
- '[ dup workspace? _ [ drop f ] if ] find-window
- [ dup raise-window gadget-child ]
- [ workspace-window* ] if* ; inline
-
-: get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
-
-: call-tool ( arg class -- )
- get-workspace show-tool call-tool* ;
-
-: get-tool ( class -- gadget )
- get-workspace find-tool nip ;
-
-: <help-pane> ( topic -- pane )
- <pane> [ [ help ] with-pane ] keep ;
-
-: help-window ( topic -- )
- [
- <help-pane> <limited-scroller>
- { 550 700 } >>max-dim
- ] [ article-title ] bi
- open-window ;
-
-: hide-popup ( workspace -- )
- dup popup>> track-remove
- f >>popup
- request-focus ;
-
-: show-popup ( gadget workspace -- )
- dup hide-popup
- over >>popup
- over f track-add drop
- request-focus ;
-
-: show-titled-popup ( workspace gadget title -- )
- [ find-workspace hide-popup ] <closable-gadget>
- swap show-popup ;
-
-: debugger-popup ( error workspace -- )
- swap dup compute-restarts
- [ find-workspace hide-popup ] <debugger>
- "Error" show-titled-popup ;
-
-SYMBOL: workspace-dim
-
-{ 600 700 } workspace-dim set-global
-
-M: workspace pref-dim* call-next-method workspace-dim get vmax ;
-
-M: workspace focusable-child*
- dup popup>> [ ] [ listener>> ] ?if ;
-
-: workspace-page ( workspace -- gadget )
- book>> current-page ;
-
-M: workspace tool-scroller ( workspace -- scroller )
- workspace-page tool-scroller ;
-
-: com-scroll-up ( workspace -- )
- tool-scroller [ scroll-up-page ] when* ;
-
-: com-scroll-down ( workspace -- )
- tool-scroller [ scroll-down-page ] when* ;
-
-workspace "scrolling"
-"The current tool's scroll pane can be scrolled from the keyboard."
-{
- { T{ key-down f { C+ } "PAGE_UP" } com-scroll-up }
- { T{ key-down f { C+ } "PAGE_DOWN" } com-scroll-down }
-} define-command-map
nip ,
] [
[
- 2dup children>> swap first head-slice %
- tuck traverse-step traverse-to-path
+ [ children>> swap first head-slice % ]
+ [ tuck traverse-step traverse-to-path ]
+ 2bi
] make-node
] if
] if ;
nip ,
] [
[
- 2dup traverse-step traverse-from-path
- tuck children>> swap first 1+ tail-slice %
+ [ traverse-step traverse-from-path ]
+ [ tuck children>> swap first 1+ tail-slice % ] 2bi
] make-node
] if
] if ;
USING: help.markup help.syntax strings quotations debugger
-io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
-ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect colors ;
+namespaces ui.backend ui.gadgets ui.gadgets.worlds
+ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids
+math.geometry.rect colors ui.text fonts ;
IN: ui
HELP: windows
{ $description "Removes a window from the global " { $link windows } " variable." }
{ $notes "This word should only be called only by the UI backend, and not user code." } ;
-HELP: ui
-{ $description "Starts the Factor UI." } ;
+HELP: (with-ui)
+{ $values { "quot" quotation } }
+{ $contract "Starts the Factor UI." }
+{ $notes "This is a low-level word; user code should call " { $link with-ui } " instead." } ;
HELP: start-ui
+{ $values { "quot" quotation } }
{ $description "Called by the UI backend to initialize the platform-independent parts of UI. This word should be called after the backend is ready to start displaying new windows, and before the event loop starts." } ;
HELP: (open-window)
{ $notes "This combinator should be used in the " { $link POSTPONE: MAIN: } " word of a vocabulary, in order for the vocabulary to work when run from the UI listener (" { $snippet "\"my-app\" run" } " and the command line (" { $snippet "./factor -run=my-app" } ")." }
{ $examples "The " { $vocab-link "hello-ui" } " vocabulary implements a simple UI application which uses this combinator." } ;
+HELP: beep
+{ $description "Plays the system beep sound." } ;
+
ARTICLE: "ui-glossary" "UI glossary"
{ $table
{ "color" { "an instance of " { $link color } } }
{ "dimension" "a pair of integers denoting pixel size on screen" }
- { "font specifier"
- { "an array of three elements:"
- { $list
- { "font family - one of " { $snippet "serif" } ", " { $snippet "sans-serif" } " or " { $snippet "monospace" } }
- { "font style - one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } }
- "font size in points"
- }
- }
- }
+ { "font" { "an instance of " { $link font } } }
{ "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) inherit from " { $link gadget } "." } }
{ "label specifier" { "a string, " { $link f } " or a gadget. See " { $link "ui.gadgets.buttons" } } }
{ "orientation specifier" { "one of " { $snippet "{ 0 1 }" } " or " { $snippet "{ 1 0 }" } ", with the former denoting vertical orientation and the latter denoting horizontal. Using a vector instead of symbolic constants allows these values to be directly useful in co-ordinate calculations" } }
{ $subsection "ui.gadgets.menus" }
{ $subsection "ui.gadgets.panes" }
{ $subsection "ui.gadgets.presentations" }
-{ $subsection "ui.gadgets.lists" } ;
+{ $subsection "ui.gadgets.lists" }
+{ $subsection "ui.gadgets.tables" } ;
ARTICLE: "ui-geometry" "Gadget geometry"
"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
"UI backends may implement the " { $link "clipboard-protocol" } "." ;
ARTICLE: "ui-backend-init" "UI initialization and the event loop"
-"An UI backend is required to define a method on the " { $link ui } " word. This word should contain backend initialization, together with some boilerplate:"
+"An UI backend is required to define a method on the " { $link (with-ui) } " word. This word should contain backend initialization, together with some boilerplate:"
{ $code
"IN: shells"
""
}
"The above word must call the following:"
{ $subsection start-ui }
-"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down." ;
+"The " { $link (with-ui) } " word must not return until the event loop has stopped and the UI has been shut down." ;
ARTICLE: "ui-backend-windows" "UI backend window management"
"The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
{ $see-also "ui-layout-impl" } ;
ARTICLE: "starting-ui" "Starting the UI"
-"The UI starts automatically where possible:"
-{ $list
- { "On Windows, the UI starts when the Factor executable is run." }
- { "On X11, the UI starts if the " { $snippet "DISPLAY" } " environment variable is set." }
- { "On Mac OS X, the UI starts if the " { $snippet "Factor.app" } " application bundle is run." }
-}
-"In all cases, passing the " { $snippet "-run=listener" } " command line switch starts the terminal listener instead. The UI can be started from the terminal listener using a word:"
-{ $subsection ui }
-"To run the terminal listener and the UI simultaneously, start the UI in a new thread:"
-{ $code "USING: threads ui ;" "[ ui ] in-thread" }
"The main word of a vocabulary implementing a UI application should use a combinator to ensure that the application works when run from the command line as well as in the UI listener:"
{ $subsection with-ui } ;
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make
-dlists deques sequences threads sequences words ui.gadgets
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend
-ui.render continuations init combinators hashtables
-concurrency.flags sets accessors calendar ;
+dlists deques sequences threads sequences words continuations
+init combinators hashtables concurrency.flags sets accessors
+calendar fry ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
+ui.gestures ui.backend ui.render ui.text ui.text.private ;
IN: ui
! Assoc mapping aliens to gadgets
: focus-gestures ( new old -- )
drop-prefix <reversed>
- T{ lose-focus } swap each-gesture
- T{ gain-focus } swap each-gesture ;
+ lose-focus swap each-gesture
+ gain-focus swap each-gesture ;
: focus-world ( world -- )
t >>focused?
[ f >>handle drop ] tri ;
: (ungraft-world) ( world -- )
- [ free-fonts ]
- [ hand-clicked close-global ]
- [ hand-gadget close-global ] tri ;
+ {
+ [ handle>> select-gl-context ]
+ [ fonts>> free-fonts ]
+ [ hand-clicked close-global ]
+ [ hand-gadget close-global ]
+ } cleave ;
M: world ungraft*
[ (ungraft-world) ]
windows get values
[ gadget-child swap call ] with find-last nip ; inline
-SYMBOL: ui-hook
-
: init-ui ( -- )
<dlist> \ graft-queue set-global
<dlist> \ layout-queue set-global
: restore-world ( world -- )
dup reset-world restore-gadget ;
-: restore-windows ( -- )
- windows get [ values ] keep delete-all
- [ restore-world ] each
- forget-rollover ;
-
-: restore-windows? ( -- ? )
- windows get empty? not ;
-
: update-hand ( world -- )
dup hand-world get-global eq?
[ hand-loc get-global swap move-hand ] [ drop ] if ;
M: object close-window
find-world [ ungraft ] when* ;
-: start-ui ( -- )
- restore-windows? [
- restore-windows
- ] [
- init-ui ui-hook get call
- ] if
- notify-ui-thread start-ui-thread ;
+: start-ui ( quot -- )
+ call notify-ui-thread start-ui-thread ;
[
f \ ui-running set-global
<flag> ui-notify-flag set-global
] "ui" add-init-hook
-HOOK: ui ui-backend ( -- )
+HOOK: (with-ui) ui-backend ( quot -- )
-MAIN: ui
+: restore-windows ( -- )
+ [
+ windows get [ values ] [ delete-all ] bi
+ [ restore-world ] each
+ forget-rollover
+ ] (with-ui) ;
+
+: restore-windows? ( -- ? )
+ windows get empty? not ;
: with-ui ( quot -- )
- ui-running? [
- call
- ] [
- f windows set-global
- [
- ui-hook set
- ui
- ] with-scope
- ] if ;
+ ui-running? [ call ] [ '[ init-ui @ ] (with-ui) ] if ;
+
+HOOK: beep ui-backend ( -- )
\ No newline at end of file
+++ /dev/null
-Doug Coleman
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2005, 2006 Doug Coleman.
-! Portions copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui
-ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
-ui.gestures ui.event-loop io kernel math math.vectors namespaces
-make sequences strings vectors words windows.kernel32
-windows.gdi32 windows.user32 windows.opengl32 windows.messages
-windows.types windows.nt windows threads libc combinators fry
-combinators.short-circuit continuations command-line shuffle
-opengl ui.render ascii math.bitwise locals accessors
-math.geometry.rect math.order ascii calendar io.encodings.utf16n
-;
-IN: ui.windows
-
-SINGLETON: windows-ui-backend
-
-: crlf>lf ( str -- str' )
- CHAR: \r swap remove ;
-
-: lf>crlf ( str -- str' )
- [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
-
-: enum-clipboard ( -- seq )
- 0
- [ EnumClipboardFormats win32-error dup dup 0 > ]
- [ ]
- [ drop ]
- produce nip ;
-
-: with-clipboard ( quot -- )
- f OpenClipboard win32-error=0/f
- call
- CloseClipboard win32-error=0/f ; inline
-
-: paste ( -- str )
- [
- CF_UNICODETEXT IsClipboardFormatAvailable zero? [
- ! nothing to paste
- ""
- ] [
- CF_UNICODETEXT GetClipboardData dup win32-error=0/f
- dup GlobalLock dup win32-error=0/f
- GlobalUnlock win32-error=0/f
- utf16n alien>string
- ] if
- ] with-clipboard
- crlf>lf ;
-
-: copy ( str -- )
- lf>crlf [
- utf16n string>alien
- EmptyClipboard win32-error=0/f
- GMEM_MOVEABLE over length 1+ GlobalAlloc
- dup win32-error=0/f
-
- dup GlobalLock dup win32-error=0/f
- swapd byte-array>memory
- dup GlobalUnlock win32-error=0/f
- CF_UNICODETEXT swap SetClipboardData win32-error=0/f
- ] with-clipboard ;
-
-TUPLE: pasteboard ;
-C: <pasteboard> pasteboard
-
-M: pasteboard clipboard-contents drop paste ;
-M: pasteboard set-clipboard-contents drop copy ;
-
-: init-clipboard ( -- )
- <pasteboard> clipboard set-global
- <clipboard> selection set-global ;
-
-TUPLE: win-base hDC hRC ;
-TUPLE: win < win-base hWnd world title ;
-TUPLE: win-offscreen < win-base hBitmap bits ;
-C: <win> win
-C: <win-offscreen> win-offscreen
-
-SYMBOLS: msg-obj class-name-ptr mouse-captured ;
-
-: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
-: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
-
-: get-RECT-top-left ( RECT -- x y )
- [ RECT-left ] keep RECT-top ;
-
-: get-RECT-dimensions ( RECT -- x y width height )
- [ get-RECT-top-left ] keep
- [ RECT-right ] keep [ RECT-left - ] keep
- [ RECT-bottom ] keep RECT-top - ;
-
-: handle-wm-paint ( hWnd uMsg wParam lParam -- )
- #! wParam and lParam are unused
- #! only paint if width/height both > 0
- 3drop window relayout-1 yield ;
-
-: handle-wm-size ( hWnd uMsg wParam lParam -- )
- 2nip
- [ lo-word ] keep hi-word 2array
- dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
-
-: handle-wm-move ( hWnd uMsg wParam lParam -- )
- 2nip
- [ lo-word ] keep hi-word 2array
- swap window (>>window-loc) ;
-
-: wm-keydown-codes ( -- key )
- H{
- { 8 "BACKSPACE" }
- { 9 "TAB" }
- { 13 "RET" }
- { 27 "ESC" }
- { 33 "PAGE_UP" }
- { 34 "PAGE_DOWN" }
- { 35 "END" }
- { 36 "HOME" }
- { 37 "LEFT" }
- { 38 "UP" }
- { 39 "RIGHT" }
- { 40 "DOWN" }
- { 45 "INSERT" }
- { 46 "DELETE" }
- { 112 "F1" }
- { 113 "F2" }
- { 114 "F3" }
- { 115 "F4" }
- { 116 "F5" }
- { 117 "F6" }
- { 118 "F7" }
- { 119 "F8" }
- { 120 "F9" }
- { 121 "F10" }
- { 122 "F11" }
- { 123 "F12" }
- } ;
-
-: key-state-down? ( key -- ? )
- GetKeyState 16 bit? ;
-
-: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
-: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
-: left-alt? ( -- ? ) VK_LMENU key-state-down? ;
-: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
-: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
-: right-alt? ( -- ? ) VK_RMENU key-state-down? ;
-: shift? ( -- ? ) left-shift? right-shift? or ;
-: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
-: alt? ( -- ? ) left-alt? right-alt? or ;
-: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
-
-: key-modifiers ( -- seq )
- [
- shift? [ S+ , ] when
- ctrl? [ C+ , ] when
- alt? [ A+ , ] when
- ] { } make [ empty? not ] keep f ? ;
-
-: exclude-keys-wm-keydown
- H{
- { 16 "SHIFT" }
- { 17 "CTRL" }
- { 18 "ALT" }
- { 20 "CAPS-LOCK" }
- } ;
-
-: exclude-keys-wm-char
- ! Values are ignored
- H{
- { 8 "BACKSPACE" }
- { 9 "TAB" }
- { 13 "RET" }
- { 27 "ESC" }
- } ;
-
-: exclude-key-wm-keydown? ( n -- ? )
- exclude-keys-wm-keydown key? ;
-
-: exclude-key-wm-char? ( n -- ? )
- exclude-keys-wm-char key? ;
-
-: keystroke>gesture ( n -- mods sym )
- wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ;
-
-: send-key-gesture ( sym action? quot hWnd -- )
- [ [ key-modifiers ] 3dip call ] dip
- window propagate-key-gesture ; inline
-
-: send-key-down ( sym action? hWnd -- )
- [ [ <key-down> ] ] dip send-key-gesture ;
-
-: send-key-up ( sym action? hWnd -- )
- [ [ <key-up> ] ] dip send-key-gesture ;
-
-: key-sym ( wParam -- string/f action? )
- {
- {
- [ dup LETTER? ]
- [ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ]
- }
- { [ dup digit? ] [ 1string f ] }
- [ wm-keydown-codes at t ]
- } cond ;
-
-:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
- wParam exclude-key-wm-keydown? [
- wParam key-sym over [
- dup ctrl? alt? xor or [
- hWnd send-key-down
- ] [ 2drop ] if
- ] [ 2drop ] if
- ] unless ;
-
-:: handle-wm-char ( hWnd uMsg wParam lParam -- )
- wParam exclude-key-wm-char? [
- ctrl? alt? xor [
- wParam 1string
- [ f hWnd send-key-down ]
- [ hWnd window user-input ] bi
- ] unless
- ] unless ;
-
-:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
- wParam exclude-key-wm-keydown? [
- wParam key-sym over [
- hWnd send-key-up
- ] [ 2drop ] if
- ] unless ;
-
-:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
- ? hwnd window (>>active?)
- hwnd uMsg wParam lParam DefWindowProc ;
-
-: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
- {
- { [ over SC_MINIMIZE = ] [ f set-window-active ] }
- { [ over SC_RESTORE = ] [ t set-window-active ] }
- { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
- { [ dup alpha? ] [ 4drop 0 ] }
- { [ t ] [ DefWindowProc ] }
- } cond ;
-
-: cleanup-window ( handle -- )
- dup title>> [ free ] when*
- dup hRC>> wglDeleteContext win32-error=0/f
- dup hWnd>> swap hDC>> ReleaseDC win32-error=0/f ;
-
-M: windows-ui-backend (close-window)
- dup hWnd>> unregister-window
- dup cleanup-window
- hWnd>> DestroyWindow win32-error=0/f ;
-
-: handle-wm-close ( hWnd uMsg wParam lParam -- )
- 3drop window ungraft ;
-
-: handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
- 3drop window [ focus-world ] when* ;
-
-: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
- 3drop window [ unfocus-world ] when* ;
-
-: message>button ( uMsg -- button down? )
- {
- { WM_LBUTTONDOWN [ 1 t ] }
- { WM_LBUTTONUP [ 1 f ] }
- { WM_MBUTTONDOWN [ 2 t ] }
- { WM_MBUTTONUP [ 2 f ] }
- { WM_RBUTTONDOWN [ 3 t ] }
- { WM_RBUTTONUP [ 3 f ] }
-
- { WM_NCLBUTTONDOWN [ 1 t ] }
- { WM_NCLBUTTONUP [ 1 f ] }
- { WM_NCMBUTTONDOWN [ 2 t ] }
- { WM_NCMBUTTONUP [ 2 f ] }
- { WM_NCRBUTTONDOWN [ 3 t ] }
- { WM_NCRBUTTONUP [ 3 f ] }
- } case ;
-
-! If the user clicks in the window border ("non-client area")
-! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
-! mouse is subsequently released outside the NC area, we receive
-! a [LMR]BUTTONUP message and Factor can get confused. So we
-! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
-SYMBOL: nc-buttons
-
-: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
- 2drop nip
- message>button nc-buttons get
- swap [ push ] [ delete ] if ;
-
-: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
-
-: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
-
-: mouse-event>gesture ( uMsg -- button )
- key-modifiers swap message>button
- [ <button-down> ] [ <button-up> ] if ;
-
-:: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
- uMsg mouse-event>gesture
- lParam >lo-hi
- hWnd window ;
-
-: set-capture ( hwnd -- )
- mouse-captured get [
- drop
- ] [
- [ SetCapture drop ] keep
- mouse-captured set
- ] if ;
-
-: release-capture ( -- )
- ReleaseCapture win32-error=0/f
- mouse-captured off ;
-
-: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
- [
- over set-capture
- dup message>button drop nc-buttons get delete
- ] 2dip prepare-mouse send-button-down ;
-
-: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
- mouse-captured get [ release-capture ] when
- pick message>button drop dup nc-buttons get member? [
- nc-buttons get delete 4drop
- ] [
- drop prepare-mouse send-button-up
- ] if ;
-
-: make-TRACKMOUSEEVENT ( hWnd -- alien )
- "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
- "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
-
-: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
- 2nip
- over make-TRACKMOUSEEVENT
- TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
- 0 over set-TRACKMOUSEEVENT-dwHoverTime
- TrackMouseEvent drop
- >lo-hi swap window move-hand fire-motion ;
-
-:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
- wParam mouse-wheel hand-loc get hWnd window send-wheel ;
-
-: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
- #! message sent if windows needs application to stop dragging
- 4drop release-capture ;
-
-: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
- #! message sent if mouse leaves main application
- 4drop forget-rollover ;
-
-SYMBOL: wm-handlers
-
-H{ } clone wm-handlers set-global
-
-: add-wm-handler ( quot wm -- )
- dup array?
- [ [ execute add-wm-handler ] with each ]
- [ wm-handlers get-global set-at ] if ;
-
-[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
-[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
-
-[ handle-wm-size 0 ] WM_SIZE add-wm-handler
-[ handle-wm-move 0 ] WM_MOVE add-wm-handler
-
-[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
-[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler
-[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler
-
-[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler
-[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
-[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
-
-[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
-[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
-[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
-[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
-[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
-[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
-
-[ 4dup handle-wm-ncbutton DefWindowProc ]
-{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
-WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
-add-wm-handler
-
-[ nc-buttons get-global delete-all DefWindowProc ]
-{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
-
-[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler
-[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
-[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
-[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
-
-SYMBOL: trace-messages?
-
-! return 0 if you handle the message, else just let DefWindowProc return its val
-: ui-wndproc ( -- object )
- "uint" { "void*" "uint" "long" "long" } "stdcall" [
- pick
- trace-messages? get-global [ dup windows-message-name name>> print flush ] when
- wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
- ] alien-callback ;
-
-: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
-
-M: windows-ui-backend do-events
- msg-obj get-global
- dup peek-message? [ drop ui-wait ] [
- [ TranslateMessage drop ]
- [ DispatchMessage drop ] bi
- ] if ;
-
-: register-wndclassex ( -- class )
- "WNDCLASSEX" <c-object>
- f GetModuleHandle
- class-name-ptr get-global
- pick GetClassInfoEx zero? [
- "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
- { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
- ui-wndproc over set-WNDCLASSEX-lpfnWndProc
- 0 over set-WNDCLASSEX-cbClsExtra
- 0 over set-WNDCLASSEX-cbWndExtra
- f GetModuleHandle over set-WNDCLASSEX-hInstance
- f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
- over set-WNDCLASSEX-hIcon
- f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
-
- class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
- RegisterClassEx dup win32-error=0/f
- ] when ;
-
-: adjust-RECT ( RECT -- )
- style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
-
-: make-RECT ( world -- RECT )
- [ window-loc>> dup ] [ rect-dim ] bi v+
- "RECT" <c-object>
- over first over set-RECT-right
- swap second over set-RECT-bottom
- over first over set-RECT-left
- swap second over set-RECT-top ;
-
-: default-position-RECT ( RECT -- )
- dup get-RECT-dimensions [ 2drop ] 2dip
- CW_USEDEFAULT + pick set-RECT-bottom
- CW_USEDEFAULT + over set-RECT-right
- CW_USEDEFAULT over set-RECT-left
- CW_USEDEFAULT swap set-RECT-top ;
-
-: make-adjusted-RECT ( rect -- RECT )
- make-RECT
- dup get-RECT-top-left [ zero? ] both? swap
- dup adjust-RECT
- swap [ dup default-position-RECT ] when ;
-
-: create-window ( rect -- hwnd )
- make-adjusted-RECT
- [ class-name-ptr get-global f ] dip
- [
- [ ex-style ] 2dip
- { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
- ] dip get-RECT-dimensions
- f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
-
-: show-window ( hWnd -- )
- dup SW_SHOW ShowWindow drop ! always succeeds
- dup SetForegroundWindow drop
- SetFocus drop ;
-
-: init-win32-ui ( -- )
- V{ } clone nc-buttons set-global
- "MSG" malloc-object msg-obj set-global
- "Factor-window" utf16n malloc-string class-name-ptr set-global
- register-wndclassex drop
- GetDoubleClickTime milliseconds double-click-timeout set-global ;
-
-: cleanup-win32-ui ( -- )
- class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
- msg-obj get-global [ free ] when*
- 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 ;
-
-M: windows-ui-backend (open-window) ( world -- )
- [ create-window [ setup-gl ] keep ] keep
- [ f <win> ] keep
- [ swap hWnd>> register-window ] 2keep
- dupd (>>handle)
- hWnd>> show-window ;
-
-M: win-base select-gl-context ( handle -- )
- [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
- GdiFlush drop ;
-
-M: win-base flush-gl-context ( handle -- )
- hDC>> SwapBuffers win32-error=0/f ;
-
-: (bitmap-info) ( dim -- BITMAPINFO )
- "BITMAPINFO" <c-object> [
- BITMAPINFO-bmiHeader {
- [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
- [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
- [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
- [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
- [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
- [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
- [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
- [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
- [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
- } 2cleave
- ] keep ;
-
-: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
- f CreateCompatibleDC
- dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
- [ f 0 CreateDIBSection ] keep *void*
- [ 2dup SelectObject drop ] dip ;
-
-: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
- make-offscreen-dc-and-bitmap [
- [ dup offscreen-pfd-dwFlags setup-pixel-format ]
- [ get-rc ] bi
- ] 2dip ;
-
-M: windows-ui-backend (open-offscreen-buffer) ( world -- )
- dup dim>> setup-offscreen-gl <win-offscreen>
- >>handle drop ;
-M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
- [ hDC>> DeleteDC drop ]
- [ hBitmap>> DeleteObject drop ] bi ;
-
-! Windows 32-bit bitmaps don't actually use the alpha byte of
-! each pixel; it's left as zero
-
-: (make-opaque) ( byte-array -- byte-array' )
- [ length 4 / ]
- [ '[ 255 swap 4 * 3 + _ set-nth ] each ]
- [ ] tri ;
-
-: (opaque-pixels) ( world -- pixels )
- [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
- memory>byte-array (make-opaque) ;
-
-M: windows-ui-backend offscreen-pixels ( world -- alien w h )
- [ (opaque-pixels) ] [ dim>> first2 ] bi ;
-
-M: windows-ui-backend raise-window* ( world -- )
- handle>> [
- hWnd>> SetFocus drop
- ] when* ;
-
-M: windows-ui-backend set-title ( string world -- )
- handle>>
- dup title>> [ free ] when*
- [ utf16n malloc-string ] dip
- 2dup (>>title)
- hWnd>> WM_SETTEXT 0 roll alien-address SendMessage drop ;
-
-M: windows-ui-backend ui
- [
- [
- init-clipboard
- init-win32-ui
- start-ui
- event-loop
- ] [ cleanup-win32-ui ] [ ] cleanup
- ] ui-running ;
-
-M: windows-ui-backend beep ( -- )
- 0 MessageBeep drop ;
-
-windows-ui-backend ui-backend set-global
-
-[ "ui" ] main-vocab-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays ui ui.gadgets
-ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
-ui.event-loop assocs kernel math namespaces opengl sequences
-strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
-x11.constants x11.windows io.encodings.string io.encodings.ascii
-io.encodings.utf8 combinators command-line
-math.vectors classes.tuple opengl.gl threads math.geometry.rect
-environment ascii ;
-IN: ui.x11
-
-SINGLETON: x11-ui-backend
-
-: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
-
-TUPLE: x11-handle-base glx ;
-TUPLE: x11-handle < x11-handle-base xic window ;
-TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
-
-C: <x11-handle> x11-handle
-C: <x11-pixmap-handle> x11-pixmap-handle
-
-M: world expose-event nip relayout ;
-
-M: world configure-event
- over configured-loc >>window-loc
- swap configured-dim >>dim
- ! In case dimensions didn't change
- relayout-1 ;
-
-: modifiers
- {
- { S+ HEX: 1 }
- { C+ HEX: 4 }
- { A+ HEX: 8 }
- } ;
-
-: key-codes
- H{
- { HEX: FF08 "BACKSPACE" }
- { HEX: FF09 "TAB" }
- { HEX: FF0D "RET" }
- { HEX: FF8D "ENTER" }
- { HEX: FF1B "ESC" }
- { HEX: FFFF "DELETE" }
- { HEX: FF50 "HOME" }
- { HEX: FF51 "LEFT" }
- { HEX: FF52 "UP" }
- { HEX: FF53 "RIGHT" }
- { HEX: FF54 "DOWN" }
- { HEX: FF55 "PAGE_UP" }
- { HEX: FF56 "PAGE_DOWN" }
- { HEX: FF57 "END" }
- { HEX: FF58 "BEGIN" }
- { HEX: FFBE "F1" }
- { HEX: FFBF "F2" }
- { HEX: FFC0 "F3" }
- { HEX: FFC1 "F4" }
- { HEX: FFC2 "F5" }
- { HEX: FFC3 "F6" }
- { HEX: FFC4 "F7" }
- { HEX: FFC5 "F8" }
- { HEX: FFC6 "F9" }
- } ;
-
-: key-code ( keysym -- keycode action? )
- dup key-codes at [ t ] [ 1string f ] ?if ;
-
-: event-modifiers ( event -- seq )
- XKeyEvent-state modifiers modifier ;
-
-: valid-input? ( string gesture -- ? )
- over empty? [ 2drop f ] [
- mods>> { f { S+ } } member? [
- [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
- ] [
- [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
- ] if
- ] if ;
-
-: key-down-event>gesture ( event world -- string gesture )
- dupd
- handle>> xic>> lookup-string
- [ swap event-modifiers ] dip key-code <key-down> ;
-
-M: world key-down-event
- [ key-down-event>gesture ] keep
- [ propagate-key-gesture drop ]
- [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
- 3bi ;
-
-: key-up-event>gesture ( event -- gesture )
- dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
-
-M: world key-up-event
- [ key-up-event>gesture ] dip propagate-key-gesture ;
-
-: mouse-event>gesture ( event -- modifiers button loc )
- [ event-modifiers ]
- [ XButtonEvent-button ]
- [ mouse-event-loc ]
- tri ;
-
-M: world button-down-event
- [ mouse-event>gesture [ <button-down> ] dip ] dip
- send-button-down ;
-
-M: world button-up-event
- [ mouse-event>gesture [ <button-up> ] dip ] dip
- send-button-up ;
-
-: mouse-event>scroll-direction ( event -- pair )
- XButtonEvent-button {
- { 4 { 0 -1 } }
- { 5 { 0 1 } }
- { 6 { -1 0 } }
- { 7 { 1 0 } }
- } at ;
-
-M: world wheel-event
- [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
- send-wheel ;
-
-M: world enter-event motion-event ;
-
-M: world leave-event 2drop forget-rollover ;
-
-M: world motion-event
- [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
- move-hand fire-motion ;
-
-M: world focus-in-event
- nip
- dup handle>> xic>> XSetICFocus focus-world ;
-
-M: world focus-out-event
- nip
- dup handle>> xic>> XUnsetICFocus unfocus-world ;
-
-M: world selection-notify-event
- [ handle>> window>> selection-from-event ] keep
- user-input ;
-
-: supported-type? ( atom -- ? )
- { "UTF8_STRING" "STRING" "TEXT" }
- [ x-atom = ] with any? ;
-
-: clipboard-for-atom ( atom -- clipboard )
- {
- { XA_PRIMARY [ selection get ] }
- { XA_CLIPBOARD [ clipboard get ] }
- [ drop <clipboard> ]
- } case ;
-
-: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target
- XA_UTF8_STRING = utf8 ascii ? encode ;
-
-: set-selection-prop ( evt -- )
- dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ XSelectionRequestEvent-target ] keep
- [ 8 PropModeReplace ] dip
- [
- XSelectionRequestEvent-selection
- clipboard-for-atom contents>>
- ] keep encode-clipboard dup length XChangeProperty drop ;
-
-M: world selection-request-event
- drop dup XSelectionRequestEvent-target {
- { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
- { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
- { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
- [ drop send-notify-failure ]
- } cond ;
-
-M: x11-ui-backend (close-window) ( handle -- )
- dup xic>> XDestroyIC
- dup glx>> destroy-glx
- window>> dup unregister-window
- destroy-window ;
-
-M: world client-event
- swap close-box? [ ungraft ] [ drop ] if ;
-
-: gadget-window ( world -- )
- dup window-loc>> over rect-dim glx-window
- over "Factor" create-xic rot <x11-handle>
- 2dup window>> register-window
- >>handle drop ;
-
-: wait-event ( -- event )
- QueuedAfterFlush events-queued 0 > [
- next-event dup
- None XFilterEvent zero? [ drop wait-event ] unless
- ] [
- ui-wait wait-event
- ] if ;
-
-M: x11-ui-backend do-events
- wait-event dup XAnyEvent-window window dup
- [ handle-event ] [ 2drop ] if ;
-
-: x-clipboard@ ( gadget clipboard -- prop win )
- atom>> swap
- find-world handle>> window>> ;
-
-M: x-clipboard copy-clipboard
- [ x-clipboard@ own-selection ] keep
- (>>contents) ;
-
-M: x-clipboard paste-clipboard
- [ find-world handle>> window>> ] dip atom>> convert-selection ;
-
-: init-clipboard ( -- )
- XA_PRIMARY <x-clipboard> selection set-global
- XA_CLIPBOARD <x-clipboard> clipboard set-global ;
-
-: set-title-old ( dpy window string -- )
- dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
-
-: set-title-new ( dpy window string -- )
- [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
- utf8 encode dup length XChangeProperty drop ;
-
-M: x11-ui-backend set-title ( string world -- )
- handle>> window>> swap
- [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
-
-M: x11-ui-backend set-fullscreen* ( ? world -- )
- handle>> window>> "XClientMessageEvent" <c-object>
- tuck set-XClientMessageEvent-window
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
- over set-XClientMessageEvent-data0
- ClientMessage over set-XClientMessageEvent-type
- dpy get over set-XClientMessageEvent-display
- "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
- 32 over set-XClientMessageEvent-format
- "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
- [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
-
-M: x11-ui-backend (open-window) ( world -- )
- dup gadget-window
- handle>> window>> dup set-closable map-window ;
-
-M: x11-ui-backend raise-window* ( world -- )
- handle>> [
- dpy get swap window>> XRaiseWindow drop
- ] when* ;
-
-M: x11-handle select-gl-context ( handle -- )
- dpy get swap
- [ window>> ] [ glx>> ] bi glXMakeCurrent
- [ "Failed to set current GLX context" throw ] unless ;
-
-M: x11-handle flush-gl-context ( handle -- )
- dpy get swap window>> glXSwapBuffers ;
-
-M: x11-pixmap-handle select-gl-context ( handle -- )
- dpy get swap
- [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
- [ "Failed to set current GLX context" throw ] unless ;
-
-M: x11-pixmap-handle flush-gl-context ( handle -- )
- drop ;
-
-M: x11-ui-backend (open-offscreen-buffer) ( world -- )
- dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
-M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
- dpy get swap
- [ glx-pixmap>> glXDestroyGLXPixmap ]
- [ pixmap>> XFreePixmap drop ]
- [ glx>> glXDestroyContext ] 2tri ;
-
-M: x11-ui-backend offscreen-pixels ( world -- alien w h )
- [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
-
-M: x11-ui-backend ui ( -- )
- [
- f [
- [
- init-clipboard
- start-ui
- event-loop
- ] with-xim
- ] with-x
- ] ui-running ;
-
-M: x11-ui-backend beep ( -- )
- dpy get 100 XBell drop ;
-
-x11-ui-backend ui-backend set-global
-
-[ "DISPLAY" os-env "ui" "listener" ? ]
-main-vocab-hook set-global
-USING: alien alien.c-types windows.com.syntax windows.ole32\r
-windows.types continuations kernel alien.syntax libc\r
-destructors accessors ;\r
+USING: alien alien.c-types alien.destructors windows.com.syntax\r
+windows.ole32 windows.types continuations kernel alien.syntax\r
+libc destructors accessors ;\r
IN: windows.com\r
\r
LIBRARY: ole32\r
: with-com-interface ( interface quot -- )\r
over [ slip ] [ com-release ] [ ] cleanup ; inline\r
\r
-TUPLE: com-destructor interface disposed ;\r
-M: com-destructor dispose* interface>> com-release ;\r
-\r
-: &com-release ( interface -- interface )\r
- dup f com-destructor boa &dispose drop ;\r
-: |com-release ( interface -- interface )\r
- dup f com-destructor boa |dispose drop ;\r
+DESTRUCTOR: com-release\r
"inspector"
"io"
"io.files"
+ "io.pathnames"
"kernel"
"listener"
"math"
"strings"
"syntax"
"tools.annotations"
+ "tools.apropos"
"tools.crossref"
+ "tools.disassembler"
"tools.memory"
"tools.profiler"
"tools.test"
{ $side-effects "seq" } ;
HELP: replace-slice
-{ $values { "new" sequence } { "seq" "a mutable sequence" } { "from" "a non-negative integer" } { "to" "a non-negative integer" } }
+{ $values { "new" sequence } { "seq" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq'" sequence } }
{ $description "Replaces a range of elements beginning at index " { $snippet "from" } " and ending before index " { $snippet "to" } " with a new sequence." }
-{ $notes "If the " { $snippet "to - from" } " is equal to the length of " { $snippet "new" } ", the sequence remains the same size, and does not have to support resizing. However, if " { $snippet "to - from" } " is not equal to the length of " { $snippet "new" } ", the " { $link set-length } " word is called on " { $snippet "seq" } ", so fixed-size sequences should not be passed in this case." }
-{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." }
-{ $side-effects "seq" } ;
+{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "seq" } "." } ;
{ push prefix suffix } related-words
{ $subsection unclip-last-slice }
{ $subsection cut-slice }
"A utility for words which use slices as iterators:"
-{ $subsection <flat-slice> } ;
+{ $subsection <flat-slice> }
+"Replacing slices with new elements:"
+{ $subsection replace-slice } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
"Iteration:"
{ $subsection move }
{ $subsection exchange }
{ $subsection copy }
-{ $subsection replace-slice }
"Many operations have constructive and destructive variants:"
{ $table
{ "Constructive" "Destructive" }
[ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test
-[ V{ 1 2 "a" "b" 5 6 7 } ] [
- { "a" "b" } 2 4 V{ 1 2 3 4 5 6 7 } clone
- [ replace-slice ] keep
+[ { 1 2 "a" "b" 5 6 7 } ] [
+ { "a" "b" } 2 4 { 1 2 3 4 5 6 7 }
+ replace-slice
] unit-test
-[ V{ 1 2 "a" "b" 6 7 } ] [
- { "a" "b" } 2 5 V{ 1 2 3 4 5 6 7 } clone
- [ replace-slice ] keep
+[ { 1 2 "a" "b" 6 7 } ] [
+ { "a" "b" } 2 5 { 1 2 3 4 5 6 7 }
+ replace-slice
] unit-test
-[ V{ 1 2 "a" "b" 4 5 6 7 } ] [
- { "a" "b" } 2 3 V{ 1 2 3 4 5 6 7 } clone
- [ replace-slice ] keep
+[ { 1 2 "a" "b" 4 5 6 7 } ] [
+ { "a" "b" } 2 3 { 1 2 3 4 5 6 7 }
+ replace-slice
] unit-test
-[ V{ 1 2 3 4 5 6 7 "a" "b" } ] [
- { "a" "b" } 7 7 V{ 1 2 3 4 5 6 7 } clone
- [ replace-slice ] keep
+[ { 1 2 3 4 5 6 7 "a" "b" } ] [
+ { "a" "b" } 7 7 { 1 2 3 4 5 6 7 }
+ replace-slice
] unit-test
-[ V{ "a" 3 } ] [
- { "a" } 0 2 V{ 1 2 3 } clone [ replace-slice ] keep
+[ { "a" 3 } ] [
+ { "a" } 0 2 { 1 2 3 } replace-slice
] unit-test
[ { 1 4 9 } ] [ { 1 2 3 } clone dup [ sq ] change-each ] unit-test
[ 5 ] [ 1 >bignum "\u000001\u000005\u000007" nth-unsafe ] unit-test
[ SBUF" before&after" ] [
- "&" 6 11 SBUF" before and after" [ replace-slice ] keep
+ "&" 6 11 SBUF" before and after" replace-slice
] unit-test
[ 3 "a" ] [ { "a" "b" "c" "a" "d" } [ "a" = ] find-last ] unit-test
[ over - ] 2dip move-backward
] if ;
-PRIVATE>
-
: open-slice ( shift from seq -- )
pick 0 = [
3drop
set-length
] if ;
+PRIVATE>
+
: delete-slice ( from to seq -- )
check-slice [ over [ - ] dip ] dip open-slice ;
: delete-nth ( n seq -- )
[ dup 1+ ] dip delete-slice ;
-: replace-slice ( new from to seq -- )
- [ [ [ dup pick length + ] dip - over ] dip open-slice ] keep
- copy ;
+: replace-slice ( new from to seq -- seq' )
+ tuck [ swap head-slice ] [ swap tail-slice ] 2bi* surround ;
: remove-nth ( n seq -- seq' )
- [ swap head-slice ] [ swap 1+ tail-slice ] 2bi append ;
+ [ [ { } ] dip dup 1+ ] dip replace-slice ;
: pop ( seq -- elt )
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test hello-unicode ;
+IN: hello-unicode.tests
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.gadgets.panes ui.gadgets.borders ui io io.styles ;
+IN: hello-unicode
+
+: <hello-gadget> ( -- gadget )
+ [
+ { { font-size 24 } } [
+ "Hello" print
+ "Grüß dich" print
+ "здравствуйте" print
+ "こんにちは" print
+ "안녕하세요" print
+ "שָׁלוֹם " print
+ ] with-style
+ ] make-pane 10 <border> ;
+
+: hello-unicode ( -- ) <hello-gadget> "გამარჯობა" open-window ;
+
+MAIN: hello-unicode
\ No newline at end of file
--- /dev/null
+Modern "Hello world" which demonstrates various Unicode scripts
USING: iokit alien alien.syntax alien.c-types kernel
-system core-foundation ;
+system core-foundation core-foundation.data
+core-foundation.dictionaries ;
IN: iokit.hid
: kIOHIDDeviceKey "IOHIDDevice" ; inline
USING: alien.syntax alien.c-types core-foundation
-core-foundation.bundles system combinators kernel sequences
-debugger io accessors ;
+core-foundation.bundles core-foundation.dictionaries system
+combinators kernel sequences debugger io accessors ;
IN: iokit
<<
TUPLE: slides < book ;
: <slides> ( slides -- gadget )
- [ <page> ] map 0 <model> slides new-book ;
+ 0 <model> slides new-book [ <page> add-gadget ] reduce ;
: change-page ( book n -- )
over control-value + over children>> length rem
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.commands help.markup help.syntax ui.gadgets
+ui.gadgets.presentations ui.operations kernel models classes ;
+IN: ui.gadgets.lists
+
+HELP: +secondary+
+{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when " { $snippet "RET" } " is pressed in a " { $link list } " gadget where the current selection is a presentation matching the operation's predicate." } ;
+
+HELP: list
+{ $class-description
+ "A list control is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
+ $nl
+ "Lists are created by calling " { $link <list> } "."
+ { $command-map list "keyboard-navigation" }
+} ;
+
+HELP: <list>
+{ $values { "hook" { $quotation "( list -- )" } } { "presenter" { $quotation "( object -- label )" } } { "model" model } { "gadget" list } }
+{ $description "Creates a new " { $link list } "."
+$nl
+"The model value must be a sequence. The list displays presentations of elements with labels obtained by applying the " { $snippet "presenter" } " quotation to each object. The " { $snippet "hook" } " quotation is called when a presentation is selected." } ;
+
+HELP: list-value
+{ $values { "list" list } { "object" object } }
+{ $description "Outputs the currently selected list value." } ;
+
+ARTICLE: "ui.gadgets.lists" "List gadgets"
+"The " { $vocab-link "ui.gadgets.lists" } " vocabulary implements lists, which displays a list of presentations (see " { $link "ui.gadgets.presentations" } ")."
+{ $subsection list }
+{ $subsection <list> }
+{ $subsection list-value } ;
+
+ABOUT: "ui.gadgets.lists"
--- /dev/null
+IN: ui.gadgets.lists.tests
+USING: ui.gadgets.lists models prettyprint math tools.test
+kernel ;
+
+[ ] [ [ drop ] [ 3 + . ] f <model> <list> invoke-value-action ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.vectors classes.tuple math.geometry.rect colors
+kernel sequences models opengl math math.order namespaces
+ui.commands ui.gestures ui.render ui.gadgets
+ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
+ui.gadgets.theme ;
+IN: ui.gadgets.lists
+
+TUPLE: list < pack index presenter color hook ;
+
+: list-theme ( list -- list )
+ selection-color >>color ; inline
+
+: <list> ( hook presenter model -- gadget )
+ list new-gadget
+ { 0 1 } >>orientation
+ 1 >>fill
+ 0 >>index
+ swap >>model
+ swap >>presenter
+ swap >>hook
+ list-theme ;
+
+: calc-bounded-index ( n list -- m )
+ control-value length 1- min 0 max ;
+
+: bound-index ( list -- )
+ dup index>> over calc-bounded-index >>index drop ;
+
+: list-presentation-hook ( list -- quot )
+ hook>> [ [ list? ] find-parent ] prepend ;
+
+: <list-presentation> ( hook elt presenter -- gadget )
+ keep [ >label text-theme ] dip
+ <presentation>
+ swap >>hook ; inline
+
+: <list-items> ( list -- seq )
+ [ list-presentation-hook ]
+ [ presenter>> ]
+ [ control-value ]
+ tri [
+ [ 2dup ] dip swap <list-presentation>
+ ] map 2nip ;
+
+M: list model-changed
+ nip
+ dup clear-gadget
+ dup <list-items> add-gadgets
+ bound-index ;
+
+: selected-rect ( list -- rect )
+ dup index>> swap children>> ?nth ;
+
+M: list draw-gadget*
+ origin get [
+ dup color>> gl-color
+ selected-rect [
+ dup loc>> [
+ dim>> gl-fill-rect
+ ] with-translation
+ ] when*
+ ] with-translation ;
+
+M: list focusable-child* drop t ;
+
+: list-value ( list -- object )
+ dup index>> swap control-value ?nth ;
+
+: scroll>selected ( list -- )
+ #! We change the rectangle's width to zero to avoid
+ #! scrolling right.
+ [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
+ scroll>rect ;
+
+: list-empty? ( list -- ? ) control-value empty? ;
+
+: select-index ( n list -- )
+ dup list-empty? [
+ 2drop
+ ] [
+ tuck control-value length rem >>index
+ [ relayout-1 ] [ scroll>selected ] bi
+ ] if ;
+
+: select-previous ( list -- )
+ [ index>> 1- ] keep select-index ;
+
+: select-next ( list -- )
+ [ index>> 1+ ] keep select-index ;
+
+: invoke-value-action ( list -- )
+ dup list-empty? [
+ dup hook>> call
+ ] [
+ [ index>> ] keep nth-gadget invoke-secondary
+ ] if ;
+
+: select-gadget ( gadget list -- )
+ tuck children>> index
+ [ swap select-index ] [ drop ] if* ;
+
+: clamp-loc ( point max -- point )
+ vmin { 0 0 } vmax ;
+
+: select-at ( point list -- )
+ [ rect-dim clamp-loc ] keep
+ [ pick-up ] keep
+ select-gadget ;
+
+: list-page ( list vec -- )
+ [ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
+ v* v+ swap select-at ;
+
+: list-page-up ( list -- ) { 0 -1 } list-page ;
+
+: list-page-down ( list -- ) { 0 1 } list-page ;
+
+list "keyboard-navigation" "Lists can be navigated from the keyboard." {
+ { T{ button-down } request-focus }
+ { T{ key-down f f "UP" } select-previous }
+ { T{ key-down f f "DOWN" } select-next }
+ { T{ key-down f f "PAGE_UP" } list-page-up }
+ { T{ key-down f f "PAGE_DOWN" } list-page-down }
+ { T{ key-down f f "RET" } invoke-value-action }
+} define-command-map
--- /dev/null
+List gadgets display a keyboard-navigatable list of presentations
projects / factor.git / commitdiff