-{
- 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>299</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 execute ;
+
+: &F ( alien -- alien ) dup <F-destructor> execute &dispose drop ; inline
+
+: |F ( alien -- alien ) dup <F-destructor> execute |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
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
-fry vocabs.parser ;
+fry vocabs.parser words.constant ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
: C-ENUM:
";" parse-tokens
- dup length
- [ [ create-in ] dip 1quotation define ] 2each ;
+ [ [ create-in ] dip define-constant ] each-index ;
parsing
: &:
{ [ os unix? ] [ "x11" ] }
} cond
] unless* "ui." prepend require
-
- "ui.freetype" 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" }
-! 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>
-! 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 ;
dup [ [ -> valueForKey: ] keep swap [ 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:
+++ /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 ) ;
-
-! 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 ;
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>> ;
+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
+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
+! 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" { } <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 alist -- 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.destructors accessors kernel ;
IN: core-foundation
TYPEDEF: void* CFTypeRef
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
-TUPLE: CFRelease-destructor alien disposed ;
-
-M: CFRelease-destructor dispose* alien>> CFRelease ;
-
-: &CFRelease ( alien -- alien )
- dup f CFRelease-destructor boa &dispose drop ; inline
-
-: |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
+ &: kCFTypeDictionaryCallBacks
+ &: 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
-! 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 ;
+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,
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 sequences libc
+core-graphics.types ;
+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
+
+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: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
+
+FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
+
+<PRIVATE
+
+: <CGBitmapContext> ( dim -- context )
+ [ product "uint" malloc-array &free ] [ first2 8 ] [ first 4 * ] tri
+ CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease
+ kCGImageAlphaPremultipliedLast CGBitmapContextCreate
+ [ "CGBitmapContextCreate failed" throw ] unless* ;
+
+: bitmap-data ( bitmap dim -- data )
+ [ CGBitmapContextGetData ]
+ [ product "uint" heap-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* 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
+combinators hashtables ;
+IN: core-text.tests
+
+: test-font ( name -- object )
+ kCTFontFamilyNameAttribute associate <CTFont> ;
+
+[ ] [ "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 <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 words parser accessors fry words hashtables
+sequences memoize assocs math math.functions locals init
+core-foundation core-foundation.strings
+core-foundation.attributed-strings core-foundation.utilities
+core-graphics core-graphics.types ;
+IN: core-text
+
+TYPEDEF: void* CTLineRef
+TYPEDEF: void* CTFontRef
+TYPEDEF: void* CTFontDescriptorRef
+
+<<
+
+: C-GLOBAL:
+ CREATE-WORD
+ dup name>> '[ _ f dlsym *void* ]
+ (( -- value )) define-declared ; parsing
+
+>>
+
+! 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
+) ;
+
+: <CTFont> ( attrs -- font )
+ [
+ >cf &CFRelease
+ CTFontDescriptorCreateWithAttributes &CFRelease
+ 0.0 f CTFontCreateWithFontDescriptor
+ ] with-destructors ;
+
+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 ) ;
+
+FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
+ CTFontRef font,
+ CGFloat size,
+ CGAffineTransform* matrix,
+ uint32_t symTraitValue,
+ uint32_t symTraitMask
+) ;
+
+: <CTLine> ( string font -- line )
+ [
+ kCTFontAttributeName associate <CFAttributedString> &CFRelease
+ CTLineCreateWithAttributedString
+ ] with-destructors ;
+
+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 ;
+
+TUPLE: line string font line bounds dim bitmap age disposed ;
+
+: bounds>dim ( bounds -- dim )
+ [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
+ [ ceiling >fixnum ]
+ bi@ 2array ;
+
+:: draw-line ( line bounds context -- )
+ context 0.0 bounds descent>> CGContextSetTextPosition
+ line context CTLineDraw ;
+
+: <line> ( string font -- line )
+ [
+ CFRetain |CFRelease
+ 2dup <CTLine> |CFRelease
+ dup line-typographic-bounds
+ dup bounds>dim 3dup [ draw-line ] with-bitmap-context
+ 0 f line boa
+ ] with-destructors ;
+
+M: line dispose*
+ [
+ [ font>> &CFRelease drop ]
+ [ line>> &CFRelease drop ] bi
+ ] with-destructors ;
+
+<PRIVATE
+
+MEMO: (cached-line) ( string font -- line ) <line> ;
+
+: cached-lines ( -- assoc )
+ \ (cached-line) "memoize" word-prop ;
+
+: set-cached-lines ( assoc -- )
+ \ (cached-line) "memoize" set-word-prop ;
+
+CONSTANT: max-line-age 5
+
+PRIVATE>
+
+: age-lines ( -- )
+ cached-lines
+ [ nip [ 1+ ] change-age age>> max-line-age <= ] assoc-filter
+ set-cached-lines ;
+
+: cached-line ( string font -- line ) (cached-line) 0 >>age ;
+
+[ \ (cached-line) reset-memoized ] "core-text" add-init-hook
\ No newline at end of file
--- /dev/null
+Binding for Mac OS X Core Text library
--- /dev/null
+unportable
+bindings
! 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 ;
IN: delegate
: protocol-words ( protocol -- words )
[ 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
<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
+[ { 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 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
+[ { 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
! 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 ;
IN: documents
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
: elt-string ( loc document elt -- string )
[ prev/next-elt ] [ drop ] 2bi doc-range ;
-TUPLE: char-elt ;
+: set-elt-string ( string loc document elt -- )
+ [ prev/next-elt ] [ drop ] 2bi set-doc-range ;
+
+SINGLETON: char-elt
: (prev-char) ( loc document quot -- loc )
{
M: char-elt next-elt
drop [ drop 1 +col ] (next-char) ;
-TUPLE: one-char-elt ;
+SINGLETON: one-char-elt
M: one-char-elt prev-elt 2drop ;
: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
: break-detector ( ? -- quot )
- [ [ blank? ] dip xor ] curry ; inline
+ '[ blank? _ xor ] ; inline
: (prev-word) ( ? col str -- col )
rot break-detector find-last-from drop ?1+ ;
[ rot break-detector find-from drop ] keep
over not [ nip length ] [ drop ] if ;
-TUPLE: one-word-elt ;
+SINGLETON: one-word-elt
M: one-word-elt prev-elt
drop
drop
[ [ f ] 2dip (next-word) ] (word-elt) ;
-TUPLE: word-elt ;
+SINGLETON: word-elt
M: word-elt prev-elt
drop
[ [ ((word-elt)) (next-word) ] (word-elt) ]
(next-char) ;
-TUPLE: one-line-elt ;
+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 ;
-TUPLE: line-elt ;
+SINGLETON: line-elt
M: line-elt prev-elt
2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
drop over first over last-line# number=
[ nip doc-end ] [ drop 1 +line ] if ;
-TUPLE: doc-elt ;
+SINGLETON: doc-elt
M: doc-elt prev-elt 3drop { 0 0 } ;
IN: freetype
<< "freetype" {
- { [ os macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
+ { [ os macosx? ] [ "libfreetype.6.dylib" "cdecl" add-library ] }
{ [ os windows? ] [ "freetype6.dll" "cdecl" add-library ] }
{ [ t ] [ drop ] }
} cond >>
[ 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
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 ;
IN: help.markup
! Simple markup language.
: ($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, 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 ": 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."
$nl
$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" }
-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 ;
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)." }
{ $examples
! 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 ;
IN: io.styles
GENERIC: stream-format ( str style stream -- )
! Presentation
SYMBOL: presented
-SYMBOL: presented-path
-SYMBOL: presented-printer
SYMBOL: href
C: <input> input
+M: input present string>> ;
+
M: input summary
[
"Input: " %
! 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" } }
+{ $values { "color" color } }
{ $description "Wrapper for " { $link glColor4d } " taking a color specifier." } ;
HELP: gl-error
{ $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 } { "type" "an OpenGL texture type" } { "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.
: 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 )
- gen-texture [
+: make-texture ( dim pixmap type -- id )
+ [ gen-texture ] 3dip swap '[
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
+ _ first2
+ 0
+ _
+ GL_UNSIGNED_BYTE
+ _
+ 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
+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 ;
+ words $words ;
: 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" ;
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
-! Copyright (C) 2006, 2008 Slava Pestov.
+! 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.cocoa.views core-foundation core-foundation.run-loop threads
-math.geometry.rect fry libc generalizations alien.c-types
-cocoa.views combinators io.thread ;
+ui.cocoa.views core-foundation core-foundation.run-loop
+core-graphics.types threads math.geometry.rect fry libc
+generalizations alien.c-types cocoa.views ui.cocoa.text
+combinators io.thread ;
IN: ui.cocoa
TUPLE: handle ;
<clipboard> selection set-global ;
: world>NSRect ( world -- NSRect )
- [ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ <NSRect> ;
+ [ window-loc>> ] [ dim>> ] bi [ first2 ] bi@ <CGRect> ;
: gadget-window ( world -- )
dup <FactorView>
[ "MiniFactor.nib" load-nib install-app-delegate ] or
] change-at
-M: cocoa-ui-backend ui
+M: cocoa-ui-backend (with-ui)
"UI" assert.app [
[
init-clipboard
cocoa-ui-backend ui-backend set-global
-[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
+[ running.app? "ui.tools" "listener" ? ] main-vocab-hook set-global
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+UI text rendering implementation using Mac OS X Core Text
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test ui.cocoa.text ;
+IN: ui.cocoa.text.tests
--- /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 kernel
+hashtables namespaces sequences ui.gadgets.worlds ui.render
+opengl opengl.gl destructors combinators core-foundation
+core-foundation.strings io.styles memoize math ;
+IN: ui.cocoa.text
+
+SINGLETON: core-text-renderer
+
+CONSTANT: font-names
+ H{
+ { "monospace" "Monaco" }
+ { "sans-serif" "Helvetica" }
+ { "serif" "Times" }
+ }
+
+: font-name ( string -- string' )
+ font-names at-default ;
+
+: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
+
+: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
+
+: font-traits ( style -- mask )
+ [ 0 ] dip {
+ { plain [ ] }
+ { bold [ (bold) ] }
+ { italic [ (italic) ] }
+ { bold-italic [ (bold) (italic) ] }
+ } case ;
+
+: 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 )
+ [
+ [
+ [ first font-name <CFString> &CFRelease ] [ third ] bi
+ f CTFontCreateWithName
+ ] [ second ] bi apply-font-traits
+ ] with-destructors ;
+
+M: core-text-renderer open-font
+ dup alien? [ cache-font ] unless ;
+
+: string-dim ( open-font string -- dim )
+ swap cached-line dim>> ;
+
+M: core-text-renderer string-width ( open-font string -- w )
+ string-dim first ;
+
+M: core-text-renderer string-height ( open-font string -- h )
+ [ " " ] when-empty string-dim second ;
+
+TUPLE: line-texture line texture age disposed ;
+
+: <line-texture> ( line -- texture )
+ dup [ dim>> ] [ bitmap>> ] bi GL_RGBA make-texture
+ 0 f \ line-texture boa ;
+
+M: line-texture dispose* texture>> delete-texture ;
+
+: line-texture ( string open-font -- texture )
+ world get fonts>> [ cached-line <line-texture> ] 2cache ;
+
+: draw-line-texture ( line-texture -- )
+ GL_TEXTURE_2D [
+ GL_TEXTURE_BIT [
+ GL_TEXTURE_COORD_ARRAY [
+ GL_TEXTURE_2D over texture>> glBindTexture
+ init-texture rect-texture-coords
+ line>> dim>> fill-rect-vertices (gl-fill-rect)
+ GL_TEXTURE_2D 0 glBindTexture
+ ] do-enabled-client-state
+ ] do-attribs
+ ] do-enabled ;
+
+M: core-text-renderer draw-string ( font string loc -- )
+ [ swap open-font line-texture draw-line-texture ] with-translation ;
+
+M: core-text-renderer x>offset ( x font string -- n )
+ swap open-font cached-line line>> swap 0 <CGPoint> CTLineGetStringIndexForPosition ;
+
+M: core-text-renderer free-fonts ( fonts -- )
+ values dispose-each ;
+
+core-text-renderer font-renderer set-global
\ 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: 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 ;
+ui.tools.listener ui.cocoa eval locals tools.vocabs ;
IN: ui.cocoa.tools
: finder-run-files ( alien -- )
[ [ 3drop ] dip finder-run-files ]
}
-{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }
- [ 3drop workspace-window f ]
+{ "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-save-image f ]
}
-{ "showFactorHelp:" "id" { "id" "SEL" "id" }
- [ 3drop "handbook" com-follow f ]
+{ "refreshAll:" "id" { "id" "SEL" "id" }
+ [ 3drop [ refresh-all ] call-listener f ]
} ;
: install-app-delegate ( -- )
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 ;
+core-foundation.strings core-graphics core-graphics.types
+threads combinators math.geometry.rect ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
#! Cocoa -> Factor UI button mapping
-> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
-: modifiers
+CONSTANT: modifiers
{
{ S+ HEX: 20000 }
{ C+ HEX: 40000 }
{ A+ HEX: 100000 }
{ M+ HEX: 80000 }
- } ;
+ }
-: key-codes
+CONSTANT: key-codes
H{
{ 71 "CLEAR" }
{ 36 "RET" }
{ 126 "UP" }
{ 116 "PAGE_UP" }
{ 121 "PAGE_DOWN" }
- } ;
+ }
: key-code ( event -- string ? )
dup -> keyCode key-codes at
-> modifierFlags modifiers modifier ;
: key-event>gesture ( event -- modifiers keycode action? )
- dup event-modifiers swap key-code ;
+ [ event-modifiers ] [ key-code ] bi ;
: send-key-event ( view gesture -- )
swap window propagate-key-gesture ;
key-event>gesture <key-up> send-key-event ;
: mouse-event>gesture ( event -- modifiers button )
- dup event-modifiers swap button ;
+ [ event-modifiers ] [ button ] bi ;
: send-button-down$ ( view event -- )
[ nip mouse-event>gesture <button-down> ]
[ CF>string NSStringPboardType = ] [ t ] if* ;
: valid-service? ( gadget send-type return-type -- ? )
- over string-or-nil? over string-or-nil? and
+ 2dup [ string-or-nil? ] [ string-or-nil? ] bi* 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 ]
+ [ [ [ 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 <NSRect> ;
+ 2bi <CGRect> ;
CLASS: {
{ +superclass+ "NSOpenGLView" }
}
{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
- [ 3drop 0 0 0 0 <NSRect> ]
+ [ 3drop 0 0 0 0 <CGRect> ]
}
{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
{ "windowDidMove:" "void" { "id" "SEL" "id" }
[
2nip -> object
- dup window-content-rect NSRect-x-y 2array
- swap -> contentView window (>>window-loc)
+ [ -> contentView window ]
+ [ window-content-rect CGRect-x-y 2array ] bi
+ >>window-loc drop
]
}
USING: help.syntax help.markup strings kernel alien opengl
-quotations ui.render io.styles freetype ;
+opengl.sprites quotations ui.render io.styles freetype ;
IN: ui.freetype
HELP: freetype
-! Copyright (C) 2005, 2008 Slava Pestov.
+! 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 assocs
+math math.vectors namespaces opengl opengl.gl opengl.sprites 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 ;
+SINGLETON: freetype-renderer
SYMBOL: open-fonts
] bind ;
M: freetype-renderer free-fonts ( world -- )
- [ handle>> select-gl-context ]
- [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
+ values [ second free-sprites ] each ;
: ttf-name ( font style -- name )
2array H{
init-font ;
M: freetype-renderer open-font ( font -- open-font )
- freetype drop open-fonts get [ <font> ] cache ;
+ dup font? [
+ freetype drop open-fonts get [ <font> ] cache
+ ] unless ;
: load-glyph ( font char -- glyph )
[ handle>> dup ] dip 0 FT_Load_Char
drop height>> ;
: glyph-size ( glyph -- dim )
- dup glyph-hori-advance ft-ceil
- swap glyph-height ft-ceil 2array ;
+ [ glyph-hori-advance ft-ceil ]
+ [ glyph-height ft-ceil ]
+ bi 2array ;
: render-glyph ( font char -- bitmap )
load-glyph dup
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
- ]
+ 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 sprite-size2 * 2 * <byte-array>
- [ copy-bitmap ] keep gray-texture ;
+ tuck dim2>> product 2 * <byte-array>
+ [ copy-bitmap ] keep [ dim2>> ] dip
+ GL_LUMINANCE_ALPHA make-texture ;
: glyph-texture-loc ( glyph font -- loc )
[ drop glyph-hori-bearing-x ft-floor ]
: 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 )
+M: freetype-renderer x>offset ( x font string -- n )
+ [ open-font ] dip
[ run-char-widths [ <= ] with find drop ] keep swap
[ ] [ length ] ?if ;
-T{ freetype-renderer } font-renderer set-global
+freetype-renderer font-renderer set-global
-UI text rendering implementation based on FreeType
+UI text rendering implementation using FreeType
--- /dev/null
+unportable
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> }
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 ;
over value>> = >>selected?
relayout-1 ;
-: <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
- '[ _ swap _ call add-gadget ] assoc-each ; inline
+: <radio-controls> ( assoc model parent quot: ( value model label -- gadget ) -- parent )
+ '[ _ swap @ add-gadget ] assoc-each ; inline
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
{ $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 }
"Use " { $link user-input* } " to change selected text." ;
ARTICLE: "gadgets-editors" "Editor gadgets"
-"An editor edits a multi-line passage of text."
+"The " { $vocab-link "ui.gadgets.editors" } " vocabulary implements editor gadgets. An editor edits a passage of text."
{ $command-map editor "general" }
{ $command-map editor "caret-motion" }
{ $command-map editor "selection" }
+{ $command-map multiline-editor "multiline" }
{ $heading "Editor words" }
{ $subsection editor }
{ $subsection <editor> }
+{ $subsection <multiline-editor> }
{ $subsection editor-string }
{ $subsection set-editor-string }
{ $subsection "gadgets-editors-selection" }
<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
-! 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
+USING: accessors arrays documents kernel math models models.filter
+namespaces locals fry make opengl opengl.gl sequences strings io.styles
+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.gestures
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 ;
+ [ stop-blinking ] [ f >>focused? relayout-1 ] bi ;
: offset>x ( col# line# editor -- x )
- [ editor-line ] keep editor-font* spin head-slice string-width ;
+ [ editor-line ] keep font>> spin head text-width ;
: loc>x ( loc editor -- x ) [ first2 swap ] dip 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-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 caret>> set-model mark>> set-model ;
: 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 ;
editor "general" f {
{ T{ key-down f f "DELETE" } delete-next-character }
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-line ( editor -- ) line-elt editor-prev ;
-: next-line ( editor -- ) T{ line-elt } editor-next ;
+: next-line ( editor -- ) line-elt editor-next ;
-: previous-word ( editor -- ) T{ word-elt } editor-prev ;
+: previous-word ( editor -- ) word-elt editor-prev ;
-: next-word ( editor -- ) T{ word-elt } editor-next ;
+: next-word ( editor -- ) word-elt editor-next ;
-: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
+: start-of-line ( editor -- ) 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 ;
+ char-elt editor-select-next ;
: select-previous-line ( editor -- )
- T{ line-elt } editor-select-prev ;
+ line-elt editor-select-prev ;
: select-next-line ( editor -- )
- T{ line-elt } editor-select-next ;
+ line-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{ 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 {
+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 }
: <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
--- /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
-! 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*
{ <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> }
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 ]
+++ /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 dup ] dip tuck 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
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
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
+ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect fry ;
IN: ui.gadgets.panes
: 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 ;
{ $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"
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{ button-down f f 3 } [ show-presentation-menu ] }
{ T{ mouse-leave } [ [ hide-status ] [ button-update ] bi ] }
{ T{ mouse-enter } [ show-mouse-help ] }
! Responding to motion too allows nested presentations to
{ $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:"
--- /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> }
-! 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 io.styles 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.gadgets.menus models math.ranges sequences combinators ;
+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 { } ] [
+ tuck [ first length 0 <repetition> ] 2dip
+ [ [ 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 length 1- min 0 max ;
+
+: 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
+ tuck initial-selected-index {
+ [ >>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 -- )
+ [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ]
+ [ >>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-row ( table -- )
+ dup selected-index>> [ 1- ] [ 0 ] if* select-row ;
+
+: next-row ( table -- )
+ dup selected-index>> [ 1+ ] [ 0 ] if* select-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{
+ { T{ mouse-enter } [ show-mouse-help ] }
+ { T{ mouse-leave } [ hide-mouse-help ] }
+ { T{ 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 ] }
+ { T{ gain-focus } [ t >>focused? drop ] }
+ { T{ 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
: 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 )
{
USING: ui.gadgets ui.render ui.gestures ui.backend help.markup
-help.syntax models opengl strings ;
+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 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 ;
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 ;
} ;
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" } }
-! 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 ;
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 ;
IN: ui.render
HELP: gadget
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." } ;
+{ $description "Outputs the width of a string." }
+{ $notes "This is a low-level word; use " { $link text-width } " instead." } ;
+
+HELP: text-width
+{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "w" "a positive integer" } }
+{ $description "Outputs the width of a piece of text." } ;
+
+HELP: string-height
+{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "h" "a positive integer" } }
+{ $description "Outputs the height of a string." }
+{ $notes "This is a low-level word; use " { $link text-height } " instead." } ;
+
+HELP: text-height
+{ $values { "font" "a font specifier" } { "text" "a string or sequence of strings" } { "h" "a positive integer" } }
+{ $description "Outputs the height of a piece of text." } ;
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" } }
+{ $values { "font" "a font specifier" } { "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
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." } ;
+{ $description "Draws a piece of text." } ;
+
+HELP: x>offset
+{ $values { "x" real } { "font" "a font specifier" } { "string" string } { "n" integer } }
+{ $description "Outputs the string index closest to the given x co-ordinate." } ;
ARTICLE: "gadgets-polygons" "Polygon gadgets"
"A polygon gadget renders a simple shaded polygon."
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 }
+{ $subsection text-height }
"Rendering text:"
-{ $subsection draw-string }
-{ $subsection draw-text } ;
+{ $subsection draw-text }
+"Low-level text protocol for UI backends:"
+{ $subsection open-font }
+{ $subsection string-width }
+{ $subsection string-height }
+{ $subsection draw-string } ;
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:"
HOOK: draw-string font-renderer ( font string loc -- )
-HOOK: x>offset font-renderer ( x open-font string -- n )
+HOOK: x>offset font-renderer ( x font string -- n )
HOOK: free-fonts font-renderer ( world -- )
-: text-height ( open-font text -- n )
- dup string? [
- string-height
- ] [
- [ string-height ] with map sum
+: text-height ( font text -- h )
+ [ open-font ] dip
+ dup string? [ string-height ] [
+ [ string-height ] with sigma
] if ;
-: text-width ( open-font text -- n )
- dup string? [
- string-width
- ] [
+: text-width ( font text -- w )
+ [ open-font ] dip
+ dup string? [ string-width ] [
[ 0 ] 2dip [ string-width max ] with each
] if ;
-: text-dim ( open-font text -- dim )
- [ text-width ] 2keep text-height 2array ;
+: text-dim ( font text -- dim )
+ [ text-width ] [ text-height ] 2bi 2array ;
: draw-text ( font text loc -- )
- over string? [
- draw-string
- ] [
+ over string? [ draw-string ] [
[
[
2dup { 0 0 } draw-string
--- /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?
+ model>> tuck value>> swap showing-definition?
[ notify-connections ] [ drop ] if ;
-: 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 }
} 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
+ui.tools.browser ui.commands 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> ;
+
+DEFER: inspector
+
+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>
+ [ inspector ] >>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 }
+ { T{ 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
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs calendar colors documents 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
+ui.commands 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 couple
+! of 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 ;
+
+: word-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 ;
\ 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 io.styles kernel math math.order
+sequences fry ;
+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 ;
+
+: 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.gadgets.editors ui.gadgets.panes listener io ;
+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-completion" "Word and vocabulary completion"
+"The listener is great"
+;
+
+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-listener-completion" } ")" }
+ { "Clickable presentations (see " { $link "ui-presentations" } ")" }
+}
+{ $command-map listener-gadget "toolbar" }
+{ $command-map listener-gadget "scrolling" }
+{ $command-map listener-gadget "multi-touch" }
+{ $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 } ")." ;
+
+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
+
+! 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
[ 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
+
+[ 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
-! 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
+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 help
+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> >>help
+ dup model>> <history> >>history
+ swap >>output ;
+
+M: interactor graft*
+ [ call-next-method ] [ dup help>> add-connection ] bi ;
+
+M: interactor ungraft*
+ [ dup help>> remove-connection ] [ call-next-method ] bi ;
+
+M: interactor model-changed
+ 2dup help>> 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 ] 2bi ;
+
+: 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 dup request-focus ] 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 ? )
+ 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 ;
+
+: pass-to-popup? ( gesture interactor -- ? )
+ [ [ key-down? ] [ key-up? ] bi or ]
+ [ completion-popup>> ]
+ bi* and ;
+
+M: interactor handle-gesture
+ 2dup pass-to-popup? [
+ 2dup completion-popup>>
+ focusable-child resend-gesture
+ [ call-next-method ] [ 2drop f ] if
+ ] [ call-next-method ] if ;
+
+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" } word-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 {
+ { T{ 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.tools.listener ui.tools.listener.completion
+ui.tools.profiler ui.tools.inspector ui.tools.traceback
+generic help.topics stack-checker
+summary 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 ;
+vocabs.parser macros.expander ;
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 -- ) . ;
: 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
+! [ 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 ;
+! : com-usage ( word -- )
+! get-workspace swap show-word-usage ;
-[ word? ] \ com-usage H{
- { +keyboard+ T{ key-down f { C+ } "U" } }
-} define-operation
+! [ word? ] \ com-usage H{
+! { +keyboard+ T{ key-down f { C+ } "U" } }
+! } define-operation
[ word? ] \ fix H{
- { +keyboard+ T{ key-down f { C+ } "F" } }
+ { +keyboard+ T{ key-down f { C+ } "f" } }
{ +listener+ t }
} define-operation
} define-operation
! Vocabularies
-: com-vocab-words ( vocab -- )
- get-workspace swap show-vocab-words ;
+! : 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
+! [ 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 . ;
+
+[ quotation? ] \ com-expand-macros H{
+ { +keyboard+ T{ key-down f { C+ } "m" } }
+ { +listener+ t }
+} define-operation
! Operations -> commands
source-editor
"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
interactor
"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 ;
+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
{ $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 } } }
{ $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 ;
IN: ui
! Assoc mapping aliens to gadgets
[ 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
! Copyright (C) 2005, 2006 Doug Coleman.
-! Portions copyright (C) 2007, 2008 Slava Pestov.
+! 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
-;
+ui.gestures ui.event-loop ui.freetype 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
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 ;
[ (opaque-pixels) ] [ dim>> first2 ] bi ;
M: windows-ui-backend raise-window* ( world -- )
- handle>> [
- hWnd>> SetFocus drop
- ] when* ;
+ 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 ;
+ swap utf16n malloc-string
+ [ >>title ]
+ [ [ hWnd>> WM_SETTEXT 0 ] dip alien-address SendMessage drop ] bi ;
-M: windows-ui-backend ui
+M: windows-ui-backend (with-ui)
[
[
init-clipboard
windows-ui-backend ui-backend set-global
-[ "ui" ] main-vocab-hook set-global
+[ "ui.tools" ] main-vocab-hook set-global
-! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
+! 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
+ui.event-loop ui.freetype 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
M: x11-ui-backend offscreen-pixels ( world -- alien w h )
[ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
-M: x11-ui-backend ui ( -- )
+M: x11-ui-backend (with-ui) ( quot -- )
[
f [
[
x11-ui-backend ui-backend set-global
-[ "DISPLAY" os-env "ui" "listener" ? ]
+[ "DISPLAY" os-env "ui.tools" "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"
+++ /dev/null
-
-USING: accessors combinators.cleave combinators.short-circuit
-concurrency.combinators destructors fry io io.directories
-io.encodings io.encodings.utf8 io.launcher io.monitors
-io.pathnames io.pipes io.ports kernel locals math namespaces
-sequences splitting strings threads ui ui.gadgets
-ui.gadgets.buttons ui.gadgets.editors ui.gadgets.labels
-ui.gadgets.packs ui.gadgets.tracks ;
-
-IN: git-tool
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: head** ( seq obj -- seq/f ) dup number? [ head ] [ dupd find drop head ] if ;
-
-: tail** ( seq obj -- seq/f )
- dup number?
- [ tail ]
- [ dupd find drop [ tail ] [ drop f ] if* ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: <process-stdout-stderr-reader> ( DESC -- process stream stream )
- [
- [let | STDOUT-PIPE [ (pipe) |dispose ]
- STDERR-PIPE [ (pipe) |dispose ] |
-
- [let | PROCESS [ DESC >process ] |
-
- PROCESS
- [ STDOUT-PIPE out>> or ] change-stdout
- [ STDERR-PIPE out>> or ] change-stderr
- run-detached
-
- STDOUT-PIPE out>> dispose
- STDERR-PIPE out>> dispose
-
- STDOUT-PIPE in>> <input-port> utf8 <decoder>
- STDERR-PIPE in>> <input-port> utf8 <decoder> ] ]
- ]
- with-destructors ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-process/result ( desc -- process )
- <process-stdout-stderr-reader>
- {
- [ contents [ string-lines ] [ f ] if* ]
- [ contents [ string-lines ] [ f ] if* ]
- }
- parallel-spread
- [ >>stdout ] [ >>stderr ] bi*
- dup wait-for-process >>status ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! process popup windows
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: popup-window ( title contents -- )
- dup string? [ ] [ "\n" join ] if
- <editor> tuck set-editor-string swap open-window ;
-
-: popup-process-window ( process -- )
- [ stdout>> [ "output" swap popup-window ] when* ]
- [ stderr>> [ "error" swap popup-window ] when* ]
- [
- [ stdout>> ] [ stderr>> ] bi or not
- [ "Process" "NO OUTPUT" popup-window ]
- when
- ]
- tri ;
-
-: popup-if-error ( process -- )
- { [ status>> 0 = not ] [ popup-process-window t ] } 1&& drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: git-process ( REPO DESC -- process )
- REPO [ DESC run-process/result ] with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-status-section ( lines section -- lines/f )
- '[ _ = ] tail**
- [
- [ "#\t" head? ] tail**
- [ "#\t" head? not ] head**
- [ 2 tail ] map
- ]
- [ f ]
- if* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: colon ( -- ch ) CHAR: : ;
-: space ( -- ch ) 32 ;
-
-: git-status-line-file ( line -- file )
- { [ colon = ] 1 [ space = not ] } [ tail** ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <git-status>
- repository
- to-commit-new
- to-commit-modified
- to-commit-deleted
- modified
- deleted
- untracked ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: check-empty ( seq -- seq/f ) dup empty? [ drop f ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: refresh-git-status ( STATUS -- STATUS )
-
- [let | LINES [ STATUS repository>> { "git" "status" } git-process stdout>> ] |
-
- STATUS
-
- LINES "# Changes to be committed:" git-status-section
- [ "new file:" head? ] filter
- [ git-status-line-file ] map
- check-empty
- >>to-commit-new
-
- LINES "# Changes to be committed:" git-status-section
- [ "modified:" head? ] filter
- [ git-status-line-file ] map
- check-empty
- >>to-commit-modified
-
- LINES "# Changes to be committed:" git-status-section
- [ "deleted:" head? ] filter
- [ git-status-line-file ] map
- check-empty
- >>to-commit-deleted
-
- LINES "# Changed but not updated:" git-status-section
- [ "modified:" head? ] filter
- [ git-status-line-file ] map
- check-empty
- >>modified
-
- LINES "# Changed but not updated:" git-status-section
- [ "deleted:" head? ] filter
- [ git-status-line-file ] map
- check-empty
- >>deleted
-
- LINES "# Untracked files:" git-status-section >>untracked ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: git-status ( REPO -- <git-status> )
-
- <git-status> new REPO >>repository refresh-git-status ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: factor-git-status ( -- <git-status> ) "resource:" git-status ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! git-tool
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: to-commit ( <git-status> -- seq )
- { to-commit-new>> to-commit-modified>> to-commit-deleted>> } 1arr concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: refresh-status-pile ( STATUS PILE -- )
-
- STATUS refresh-git-status drop
-
- PILE clear-gadget
-
- PILE
-
- ! Commit section
-
- [wlet | add-commit-path-button [| TEXT PATH |
-
- { 1 0 } <track>
-
- TEXT <label> 2/8 track-add
- PATH <label> 6/8 track-add
-
- "Reset"
- [
- drop
-
- STATUS repository>>
- { "git" "reset" "HEAD" PATH }
- git-process
- drop
-
- STATUS PILE refresh-status-pile
- ]
- <bevel-button> f track-add
-
- add-gadget ] |
-
- STATUS to-commit
- [
- "Changes to be committed" <label> reverse-video-theme add-gadget
-
- STATUS to-commit-new>>
- [| PATH | "new file: " PATH add-commit-path-button ]
- each
-
- STATUS to-commit-modified>>
- [| PATH | "modified: " PATH add-commit-path-button ]
- each
-
- STATUS to-commit-deleted>>
- [| PATH | "deleted: " PATH add-commit-path-button ]
- each
-
- <pile> 1 >>fill
-
- [let | EDITOR [ <editor> "COMMIT MESSAGE" over set-editor-string ] |
-
- EDITOR add-gadget
-
- "Commit"
- [
- drop
- [let | MSG [ EDITOR editor-string ] |
-
- STATUS repository>>
- { "git" "commit" "-m" MSG } git-process
- popup-if-error ]
- STATUS PILE refresh-status-pile
- ]
- <bevel-button>
- add-gadget ]
-
- add-gadget
-
- ]
- when ]
-
- ! Modified section
-
- STATUS modified>>
- [
- "Modified but not updated" <label> reverse-video-theme add-gadget
-
- STATUS modified>>
- [| PATH |
-
- <shelf>
-
- PATH <label> add-gadget
-
- "Add"
- [
- drop
- STATUS repository>> { "git" "add" PATH } git-process popup-if-error
- STATUS PILE refresh-status-pile
- ]
- <bevel-button> add-gadget
-
- "Diff"
- [
- drop
- STATUS repository>> { "git" "diff" PATH } git-process
- popup-process-window
- ]
- <bevel-button> add-gadget
-
- add-gadget
-
- ]
- each
-
- ]
- when
-
- ! Untracked section
-
- STATUS untracked>>
- [
- "Untracked files" <label> reverse-video-theme add-gadget
-
- STATUS untracked>>
- [| PATH |
-
- { 1 0 } <track>
-
- PATH <label> f track-add
-
- "Add"
- [
- drop
- STATUS repository>> { "git" "add" PATH } git-process popup-if-error
- STATUS PILE refresh-status-pile
- ]
- <bevel-button> f track-add
-
- add-gadget
-
- ]
- each
-
- ]
- when
-
- ! Refresh button
-
- "Refresh" [ drop STATUS PILE refresh-status-pile ] <bevel-button> add-gadget
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: git-remote-branches ( REPO NAME -- seq )
- REPO { "git" "remote" "show" NAME } git-process stdout>>
- " Tracked remote branches" over index 1 + tail first " " split
- [ empty? not ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: refresh-remotes-pile ( REPO PILE -- )
-
- PILE clear-gadget
-
- PILE
-
- "Remotes" <label> reverse-video-theme add-gadget
-
- REPO { "git" "remote" } git-process stdout>> [ empty? not ] filter
-
- [| NAME |
-
- [let | BRANCH! [ "master" ] |
-
- { 1 0 } <track>
-
- NAME <label> 1 track-add
-
- [let | BRANCH-BUTTON [ "master" [ drop ] <bevel-button> ] |
-
- BRANCH-BUTTON
- [
- drop
-
- <pile>
-
- 1 >>fill
-
- REPO NAME git-remote-branches
- [| OTHER-BRANCH |
- OTHER-BRANCH
- [
- drop
-
- OTHER-BRANCH BRANCH!
-
- OTHER-BRANCH BRANCH-BUTTON gadget-child set-label-string
-
- ]
- <bevel-button>
- add-gadget
- ]
- each
-
- "Select a branch" open-window
- ]
- >>quot
-
- 1 track-add ]
-
- "Fetch"
- [ drop REPO { "git" "fetch" NAME } git-process popup-process-window ]
- <bevel-button>
- 1 track-add
-
- "..remote/branch"
- [
- drop
- [let | ARG [ { ".." NAME "/" BRANCH } concat ] |
- REPO { "git" "log" ARG } git-process popup-process-window ]
- ]
- <bevel-button>
- 1 track-add
-
- "Merge"
- [
- drop
- [let | ARG [ { NAME "/" BRANCH } concat ] |
- REPO { "git" "merge" ARG } git-process popup-process-window ]
- ]
- <bevel-button>
- 1 track-add
-
- "remote/branch.."
- [
- drop
- [let | ARG [ { NAME "/" BRANCH ".." } concat ] |
- REPO { "git" "log" ARG } git-process popup-process-window ]
- ]
- <bevel-button>
- 1 track-add
-
- "Push"
- [
- drop
- REPO { "git" "push" NAME "master" } git-process popup-process-window
- ]
- <bevel-button>
- 1 track-add
-
- add-gadget ]
-
- ]
- each
-
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: git-tool ( REPO -- )
-
- <pile> 1 >>fill
-
- "Repository: " REPO [ current-directory get ] with-directory append
- <label>
- add-gadget
-
- [let | STATUS [ REPO git-status ]
- PILE [ <pile> 1 >>fill ] |
-
- [
- [
- [let | MONITOR [ REPO t <monitor> ] |
- [
- [let | PATH [ MONITOR next-change drop ] |
- ".git" PATH subseq? ! Ignore git internal operations
- [ ]
- [ STATUS PILE refresh-status-pile ]
- if
- t ]
- ]
- loop
- ]
- ]
- with-monitors
- ]
- in-thread
-
- STATUS PILE refresh-status-pile
-
- PILE add-gadget ]
-
- REPO <pile> 1 >>fill tuck refresh-remotes-pile add-gadget
-
- "Git" open-window ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: factor-git-tool ( -- ) "resource:" git-tool ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: accessors calendar git-tool git-tool io.directories
-io.monitors io.pathnames kernel locals math namespaces
-sequences splitting system threads ui ui.gadgets
-ui.gadgets.buttons ui.gadgets.labels ui.gadgets.packs ;
-
-USING: git-tool ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-IN: git-tool.remote
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <git-remote-gadget> < pack
- repository
- branch
- remote
- remote-branch
- fetch-period
- push
- closed
- last-refresh ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: current-branch ( REPO -- branch )
- { "git" "branch" } git-process stdout>> [ "* " head? ] find nip 2 tail ;
-
-: list-branches ( REPO -- branches )
- { "git" "branch" } git-process stdout>>
- [ empty? not ] filter
- [ 2 tail ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: list-remotes ( REPO -- remotes )
- { "git" "remote" } git-process stdout>> [ empty? not ] filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: list-remote-branches ( REPO REMOTE -- branches )
- [let | OUT [ REPO { "git" "remote" "show" REMOTE } git-process stdout>> ] |
-
- " Tracked remote branches" OUT member?
- [
- OUT
- " Tracked remote branches" OUT index 1 + tail first " " split
- [ empty? not ] filter
- ]
- [
- OUT
- OUT [ " New remote branches" head? ] find drop
- 1 + tail first " " split
- [ empty? not ] filter
- ]
- if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: refresh-git-remote-gadget ( GADGET -- )
-
- [let | REPO [ GADGET repository>> ] |
-
- GADGET clear-gadget
-
- GADGET
-
- ! Repository label
-
- "Repository: " REPO [ current-directory get ] with-directory append
- <label>
- add-gadget
-
- ! Branch button
-
- <shelf>
-
- "Branch: " <label> add-gadget
-
- REPO current-branch
- [
- drop
-
- <pile>
- REPO list-branches
-
- [| BRANCH |
-
- BRANCH
- [
- drop
- REPO { "git" "checkout" BRANCH } git-process popup-if-error
- GADGET refresh-git-remote-gadget
- ]
- <bevel-button> add-gadget
-
- ]
- each
-
- "Select a branch" open-window
-
- ]
- <bevel-button> add-gadget
-
- add-gadget
-
- ! Remote button
-
- <shelf>
-
- "Remote: " <label> add-gadget
-
- GADGET remote>>
- [
- drop
-
- <pile>
-
- REPO list-remotes
-
- [| REMOTE |
-
- REMOTE
- [
- drop
- GADGET REMOTE >>remote drop
- GADGET "master" >>remote-branch drop
- GADGET refresh-git-remote-gadget
- ]
- <bevel-button> add-gadget
-
- ]
- each
-
- "Select a remote" open-window
-
- ]
- <bevel-button> add-gadget
-
- add-gadget
-
- ! Remote branch button
-
- <shelf>
-
- "Remote branch: " <label> add-gadget
-
- GADGET remote-branch>>
- [
- drop
-
- <pile>
-
- REPO GADGET remote>> list-remote-branches
-
- [| REMOTE-BRANCH |
-
- REMOTE-BRANCH
- [
- drop
- GADGET REMOTE-BRANCH >>remote-branch drop
- GADGET refresh-git-remote-gadget
- ]
- <bevel-button> add-gadget
- ]
-
- each
-
- "Select a remote branch" open-window
-
- ]
- <bevel-button> add-gadget
-
- add-gadget
-
- ! Fetch button
-
- "Fetch"
- [
- drop
- [let | REMOTE [ GADGET remote>> ] |
- REPO { "git" "fetch" REMOTE } git-process popup-if-error ]
-
- GADGET refresh-git-remote-gadget
- ]
- <bevel-button> add-gadget
-
- ! Available changes
-
- [let | REMOTE [ GADGET remote>> ]
- REMOTE-BRANCH [ GADGET remote-branch>> ] |
-
- [let | ARG [ { ".." REMOTE "/" REMOTE-BRANCH } concat ] |
-
- [let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
-
- PROCESS stdout>>
- [
- <shelf>
-
- "Changes available:" <label> add-gadget
-
- "View"
- [
- drop
- PROCESS popup-process-window
- ]
- <bevel-button> add-gadget
-
- "Merge"
- [
- drop
-
- [let | ARG [ { REMOTE "/" REMOTE-BRANCH } concat ] |
-
- REPO { "git" "merge" ARG } git-process popup-process-window
-
- ]
-
- GADGET refresh-git-remote-gadget
-
- ]
- <bevel-button> add-gadget
-
- add-gadget
-
- ]
- when
-
- ] ] ]
-
-
- ! Pushable changes
-
- [let | REMOTE [ GADGET remote>> ]
- REMOTE-BRANCH [ GADGET remote-branch>> ] |
-
- [let | ARG [ { REMOTE "/" REMOTE-BRANCH ".." } concat ] |
-
- [let | PROCESS [ REPO { "git" "log" ARG } git-process ] |
-
- PROCESS stdout>>
- [
- <shelf>
-
- "Pushable changes: " <label> add-gadget
-
- "View"
- [
- drop
- PROCESS popup-process-window
- ]
- <bevel-button> add-gadget
-
- "Push"
- [
- drop
-
- REPO { "git" "push" REMOTE REMOTE-BRANCH }
- git-process
- popup-process-window
-
- GADGET refresh-git-remote-gadget
-
- ]
- <bevel-button> add-gadget
-
- add-gadget
-
- ]
- when
-
- ] ] ]
-
- drop
-
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-fetch-thread ( GADGET -- )
-
- GADGET f >>closed drop
-
- [
-
- [
-
- GADGET closed>>
- [ f ]
- [
- [let | REPO [ GADGET repository>> ]
- REMOTE-BRANCH [ GADGET remote-branch>> ] |
-
- REPO { "git" "fetch" REMOTE-BRANCH } git-process drop ]
-
- GADGET fetch-period>> sleep
-
- t
- ]
- if
-
-
- ]
- loop
-
- ]
-
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-monitor-thread ( GADGET -- )
-
- GADGET f >>closed drop
-
- [
- [
- [let | MONITOR [ GADGET repository>> t <monitor> ] |
-
- [
- GADGET closed>>
- [ f ]
- [
-
- [let | PATH [ MONITOR next-change drop ] |
-
- ".git" PATH subseq?
- [ ]
- [
- micros
- GADGET last-refresh>> 0 or -
- 1000000 >
- [
- GADGET micros >>last-refresh drop
- GADGET refresh-git-remote-gadget
- ]
- when
- ]
- if ]
-
- t
-
- ]
- if
- ]
- loop
- ]
- ]
- with-monitors
- ]
- in-thread ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: <git-remote-gadget> pref-dim* ( gadget -- dim ) drop { 500 500 } ;
-
-M:: <git-remote-gadget> graft* ( GADGET -- )
- GADGET start-fetch-thread
- GADGET start-monitor-thread ;
-
-M:: <git-remote-gadget> ungraft* ( GADGET -- ) GADGET t >>closed drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: git-remote-tool ( REPO -- )
-
- <git-remote-gadget> new-gadget
-
- { 0 1 } >>orientation
- 1 >>fill
-
- REPO >>repository
-
- "origin" >>remote
-
- "master" >>remote-branch
-
- 5 minutes >>fetch-period
-
- dup refresh-git-remote-gadget
-
- "git-remote-tool" open-window ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: factor-git-remote-tool ( -- ) "resource:" git-remote-tool ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: factor-git-remote-tool
\ No newline at end of file
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