--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces opengl opengl.gl ;
+IN: ui.backend
+
+SYMBOL: ui-backend
+
+HOOK: do-events ui-backend ( -- )
+
+HOOK: set-title ui-backend ( string world -- )
+
+HOOK: set-fullscreen* ui-backend ( ? world -- )
+
+HOOK: fullscreen* ui-backend ( world -- ? )
+
+HOOK: (open-window) ui-backend ( world -- )
+
+HOOK: (close-window) ui-backend ( handle -- )
+
+HOOK: raise-window* ui-backend ( world -- )
+
+HOOK: select-gl-context ui-backend ( handle -- )
+
+HOOK: flush-gl-context ui-backend ( handle -- )
+
+HOOK: beep ui-backend ( -- )
+
+: with-gl-context ( handle quot -- )
+ swap [ select-gl-context call ] keep
+ glFlush flush-gl-context gl-error ; inline
--- /dev/null
+UI backend hooks
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets ui.gestures help.markup help.syntax strings ;
+IN: ui.clipboards
+
+HELP: clipboard
+{ $var-description "Global variable holding the system clipboard. By convention, text should only be copied to the clipboard via an explicit user action, for example by pressing " { $snippet "C+c" } "." }
+{ $class-description "A mutable container for a single string implementing the " { $link "clipboard-protocol" } "." } ;
+
+HELP: paste-clipboard
+{ $values { "gadget" gadget } { "clipboard" "an object" } }
+{ $contract "Arranges for the contents of the clipboard to be inserted into the gadget at some point in the near future via a call to " { $link user-input } ". The gadget must be grafted." } ;
+
+HELP: copy-clipboard
+{ $values { "string" string } { "gadget" gadget } { "clipboard" "an object" } }
+{ $contract "Arranges for the string to be copied to the clipboard on behalf of the gadget. The gadget must be grafted." } ;
+
+HELP: selection
+{ $var-description "Global variable holding the system selection. By convention, text should be copied to the selection as soon as it is selected by the user." } ;
+
+ARTICLE: "clipboard-protocol" "Clipboard protocol"
+"Custom gadgets that wish to interact with the clipboard must use the following two generic words to read and write clipboard contents:"
+{ $subsection paste-clipboard }
+{ $subsection copy-clipboard }
+"UI backends can either implement the above two words in the case of an asynchronous clipboard model (for example, X11). If direct access to the clipboard is provided (Windows, Mac OS X), the following two generic words may be implemented instead:"
+{ $subsection clipboard-contents }
+{ $subsection set-clipboard-contents }
+"However, gadgets should not call these words, since they will fail if only the asynchronous method of clipboard access is supported by the backend in use."
+$nl
+"Access to two clipboards is provided:"
+{ $subsection clipboard }
+{ $subsection selection }
+"These variables may contain clipboard protocol implementations which transfer data to and from the native system clipboard. However an UI backend may leave one or both of these variables in their default state, which is a trivial clipboard implementation internal to the Factor UI." ;
+
+ABOUT: "clipboard-protocol"
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ui.gadgets ui.gestures namespaces ;
+IN: ui.clipboards
+
+! Two text transfer buffers
+TUPLE: clipboard contents ;
+: <clipboard> ( -- clipboard ) "" clipboard boa ;
+
+GENERIC: paste-clipboard ( gadget clipboard -- )
+
+M: object paste-clipboard
+ clipboard-contents dup [ swap user-input ] [ 2drop ] if ;
+
+GENERIC: copy-clipboard ( string gadget clipboard -- )
+
+M: object copy-clipboard nip set-clipboard-contents ;
+
+SYMBOL: clipboard
+SYMBOL: selection
+
+: gadget-copy ( gadget clipboard -- )
+ over gadget-selection? [
+ >r [ gadget-selection ] keep r> copy-clipboard
+ ] [
+ 2drop
+ ] if ;
+
+: com-copy ( gadget -- ) clipboard get gadget-copy ;
+
+: com-copy-selection ( gadget -- ) selection get gadget-copy ;
--- /dev/null
+Abstract clipboard support
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math arrays cocoa cocoa.application
+command-line kernel memory namespaces cocoa.messages
+cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
+cocoa.windows cocoa.classes cocoa.application sequences system
+ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
+ui.cocoa.views core-foundation threads math.geometry.rect ;
+IN: ui.cocoa
+
+TUPLE: handle view window ;
+
+C: <handle> handle
+
+SINGLETON: cocoa-ui-backend
+
+M: cocoa-ui-backend do-events ( -- )
+ [
+ [ NSApp [ do-event ] curry loop ui-wait ] ui-try
+ ] with-autorelease-pool ;
+
+TUPLE: pasteboard handle ;
+
+C: <pasteboard> pasteboard
+
+M: pasteboard clipboard-contents
+ pasteboard-handle pasteboard-string ;
+
+M: pasteboard set-clipboard-contents
+ pasteboard-handle set-pasteboard-string ;
+
+: init-clipboard ( -- )
+ NSPasteboard -> generalPasteboard <pasteboard>
+ clipboard set-global
+ <clipboard> selection set-global ;
+
+: world>NSRect ( world -- NSRect )
+ dup window-loc>> first2 rot rect-dim first2 <NSRect> ;
+
+: gadget-window ( world -- )
+ [
+ dup <FactorView>
+ dup rot world>NSRect <ViewWindow>
+ dup install-window-delegate
+ over -> release
+ <handle>
+ ] keep set-world-handle ;
+
+M: cocoa-ui-backend set-title ( string world -- )
+ world-handle handle-window swap <NSString> -> setTitle: ;
+
+: enter-fullscreen ( world -- )
+ world-handle handle-view
+ NSScreen -> mainScreen
+ f -> enterFullScreenMode:withOptions:
+ drop ;
+
+: exit-fullscreen ( world -- )
+ world-handle handle-view f -> exitFullScreenModeWithOptions: ;
+
+M: cocoa-ui-backend set-fullscreen* ( ? world -- )
+ swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+
+M: cocoa-ui-backend fullscreen* ( world -- ? )
+ world-handle handle-view -> isInFullScreenMode zero? not ;
+
+: auto-position ( world -- )
+ dup window-loc>> { 0 0 } = [
+ world-handle handle-window -> center
+ ] [
+ drop
+ ] if ;
+
+M: cocoa-ui-backend (open-window) ( world -- )
+ dup gadget-window
+ dup auto-position
+ world-handle handle-window f -> makeKeyAndOrderFront: ;
+
+M: cocoa-ui-backend (close-window) ( handle -- )
+ handle-window -> release ;
+
+M: cocoa-ui-backend close-window ( gadget -- )
+ find-world [
+ world-handle [
+ handle-window f -> performClose:
+ ] when*
+ ] when* ;
+
+M: cocoa-ui-backend raise-window* ( world -- )
+ world-handle [
+ handle-window dup f -> orderFront: -> makeKeyWindow
+ NSApp 1 -> activateIgnoringOtherApps:
+ ] when* ;
+
+M: cocoa-ui-backend select-gl-context ( handle -- )
+ handle-view -> openGLContext -> makeCurrentContext ;
+
+M: cocoa-ui-backend flush-gl-context ( handle -- )
+ handle-view -> openGLContext -> flushBuffer ;
+
+M: cocoa-ui-backend beep ( -- )
+ NSBeep ;
+
+SYMBOL: cocoa-init-hook
+
+M: cocoa-ui-backend ui
+ "UI" assert.app [
+ [
+ init-clipboard
+ cocoa-init-hook get [ call ] when*
+ start-ui
+ finish-launching
+ event-loop
+ ] ui-running
+ ] with-cocoa ;
+
+cocoa-ui-backend ui-backend set-global
+
+[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
--- /dev/null
+Cocoa UI backend
--- /dev/null
+unportable
--- /dev/null
+Slava Pestov
--- /dev/null
+Cocoa integration for UI developer tools
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2006, 2007 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 help.topics kernel memory namespaces parser
+system ui ui.tools.browser ui.tools.listener ui.tools.workspace
+ui.cocoa eval ;
+IN: ui.cocoa.tools
+
+: finder-run-files ( alien -- )
+ CF>string-array listener-run-files
+ NSApp NSApplicationDelegateReplySuccess
+ -> replyToOpenOrPrint: ;
+
+: menu-run-files ( -- )
+ open-panel [ listener-run-files ] when* ;
+
+: menu-save-image ( -- )
+ image save-panel [ save-image ] when* ;
+
+! Handle Open events from the Finder
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorApplicationDelegate" }
+}
+
+{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
+ [ >r 3drop r> finder-run-files ]
+}
+
+{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }
+ [ 3drop workspace-window f ]
+}
+
+{ "runFactorFile:" "id" { "id" "SEL" "id" }
+ [ 3drop menu-run-files f ]
+}
+
+{ "saveFactorImage:" "id" { "id" "SEL" "id" }
+ [ 3drop save f ]
+}
+
+{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
+ [ 3drop menu-save-image f ]
+}
+
+{ "showFactorHelp:" "id" { "id" "SEL" "id" }
+ [ 3drop "handbook" com-follow f ]
+} ;
+
+: install-app-delegate ( -- )
+ NSApp FactorApplicationDelegate install-delegate ;
+
+! Service support; evaluate Factor code from other apps
+: do-service ( pboard error quot -- )
+ pick >r >r
+ ?pasteboard-string dup [ r> call ] [ r> 2drop f ] if
+ dup [ r> set-pasteboard-string ] [ r> 2drop ] if ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorServiceProvider" }
+} {
+ "evalInListener:userData:error:"
+ "void"
+ { "id" "SEL" "id" "id" "void*" }
+ [ nip [ eval-listener f ] do-service 2drop ]
+} {
+ "evalToString:userData:error:"
+ "void"
+ { "id" "SEL" "id" "id" "void*" }
+ [ nip [ eval>string ] do-service 2drop ]
+} ;
+
+: register-services ( -- )
+ NSApp
+ FactorServiceProvider -> alloc -> init
+ -> setServicesProvider: ;
+
+FUNCTION: void NSUpdateDynamicServices ;
+
+[
+ install-app-delegate
+ "Factor.nib" load-nib
+ register-services
+] cocoa-init-hook set-global
--- /dev/null
+Slava Pestov
--- /dev/null
+Cocoa NSView implementation displaying Factor gadgets
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays assocs cocoa kernel
+math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
+cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
+sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
+core-foundation threads combinators math.geometry.rect ;
+IN: ui.cocoa.views
+
+: send-mouse-moved ( view event -- )
+ over >r mouse-location r> window move-hand fire-motion ;
+
+: button ( event -- n )
+ #! Cocoa -> Factor UI button mapping
+ -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
+
+: modifiers
+ {
+ { S+ HEX: 20000 }
+ { C+ HEX: 40000 }
+ { A+ HEX: 80000 }
+ { M+ HEX: 100000 }
+ } ;
+
+: key-codes
+ H{
+ { 71 "CLEAR" }
+ { 36 "RET" }
+ { 76 "ENTER" }
+ { 53 "ESC" }
+ { 48 "TAB" }
+ { 51 "BACKSPACE" }
+ { 115 "HOME" }
+ { 117 "DELETE" }
+ { 119 "END" }
+ { 122 "F1" }
+ { 120 "F2" }
+ { 99 "F3" }
+ { 118 "F4" }
+ { 96 "F5" }
+ { 97 "F6" }
+ { 98 "F7" }
+ { 100 "F8" }
+ { 123 "LEFT" }
+ { 124 "RIGHT" }
+ { 125 "DOWN" }
+ { 126 "UP" }
+ { 116 "PAGE_UP" }
+ { 121 "PAGE_DOWN" }
+ } ;
+
+: key-code ( event -- string ? )
+ dup -> keyCode key-codes at
+ [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if ;
+
+: event-modifiers ( event -- modifiers )
+ -> modifierFlags modifiers modifier ;
+
+: key-event>gesture ( event -- modifiers keycode action? )
+ dup event-modifiers swap key-code ;
+
+: send-key-event ( view event quot -- ? )
+ >r key-event>gesture r> call swap window-focus
+ send-gesture ; inline
+
+: send-user-input ( view string -- )
+ CF>string swap window-focus user-input ;
+
+: interpret-key-event ( view event -- )
+ NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
+
+: send-key-down-event ( view event -- )
+ 2dup [ <key-down> ] send-key-event
+ [ interpret-key-event ] [ 2drop ] if ;
+
+: send-key-up-event ( view event -- )
+ [ <key-up> ] send-key-event drop ;
+
+: mouse-event>gesture ( event -- modifiers button )
+ dup event-modifiers swap button ;
+
+: send-button-down$ ( view event -- )
+ [ mouse-event>gesture <button-down> ] 2keep
+ mouse-location rot window send-button-down ;
+
+: send-button-up$ ( view event -- )
+ [ mouse-event>gesture <button-up> ] 2keep
+ mouse-location rot window send-button-up ;
+
+: send-wheel$ ( view event -- )
+ over >r
+ dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
+ mouse-location
+ r> window send-wheel ;
+
+: send-action$ ( view event gesture -- junk )
+ >r drop window r> send-action f ;
+
+: add-resize-observer ( observer object -- )
+ >r "updateFactorGadgetSize:"
+ "NSViewFrameDidChangeNotification" <NSString>
+ r> add-observer ;
+
+: string-or-nil? ( NSString -- ? )
+ [ CF>string NSStringPboardType = ] [ t ] if* ;
+
+: valid-service? ( gadget send-type return-type -- ? )
+ over string-or-nil? over string-or-nil? and [
+ drop [ gadget-selection? ] [ drop t ] if
+ ] [
+ 3drop f
+ ] if ;
+
+: NSRect>rect ( NSRect world -- rect )
+ >r dup NSRect-x over NSRect-y r>
+ rect-dim second swap - 2array
+ over NSRect-w rot NSRect-h 2array
+ <rect> ;
+
+: rect>NSRect ( rect world -- NSRect )
+ over rect-loc first2 rot rect-dim second swap -
+ rot rect-dim first2 <NSRect> ;
+
+CLASS: {
+ { +superclass+ "NSOpenGLView" }
+ { +name+ "FactorView" }
+ { +protocols+ { "NSTextInput" } }
+}
+
+! Rendering
+! Rendering
+{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
+ [ 3drop window relayout-1 ]
+}
+
+! Events
+{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
+ [ 3drop 1 ]
+}
+
+{ "mouseEntered:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "mouseExited:" "void" { "id" "SEL" "id" }
+ [ [ 3drop forget-rollover ] ui-try ]
+}
+
+{ "mouseMoved:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "mouseDragged:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
+ [ [ nip send-mouse-moved ] ui-try ]
+}
+
+{ "mouseDown:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-down$ ] ui-try ]
+}
+
+{ "mouseUp:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-up$ ] ui-try ]
+}
+
+{ "rightMouseDown:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-down$ ] ui-try ]
+}
+
+{ "rightMouseUp:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-up$ ] ui-try ]
+}
+
+{ "otherMouseDown:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-down$ ] ui-try ]
+}
+
+{ "otherMouseUp:" "void" { "id" "SEL" "id" }
+ [ [ nip send-button-up$ ] ui-try ]
+}
+
+{ "scrollWheel:" "void" { "id" "SEL" "id" }
+ [ [ nip send-wheel$ ] ui-try ]
+}
+
+{ "keyDown:" "void" { "id" "SEL" "id" }
+ [ [ nip send-key-down-event ] ui-try ]
+}
+
+{ "keyUp:" "void" { "id" "SEL" "id" }
+ [ [ nip send-key-up-event ] ui-try ]
+}
+
+{ "cut:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ cut-action } send-action$ ] ui-try ]
+}
+
+{ "copy:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ copy-action } send-action$ ] ui-try ]
+}
+
+{ "paste:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ paste-action } send-action$ ] ui-try ]
+}
+
+{ "delete:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ delete-action } send-action$ ] ui-try ]
+}
+
+{ "selectAll:" "id" { "id" "SEL" "id" }
+ [ [ nip T{ select-all-action } send-action$ ] ui-try ]
+}
+
+! Multi-touch gestures: this is undocumented.
+! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
+{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaZ sgn {
+ { 1 [ T{ zoom-in-action } send-action$ ] }
+ { -1 [ T{ zoom-out-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+}
+
+{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaX sgn {
+ { 1 [ T{ left-action } send-action$ ] }
+ { -1 [ T{ right-action } send-action$ ] }
+ { 0
+ [
+ dup -> deltaY sgn {
+ { 1 [ T{ up-action } send-action$ ] }
+ { -1 [ T{ down-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+ }
+ } case
+ ]
+}
+
+! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
+
+{ "acceptsFirstResponder" "bool" { "id" "SEL" }
+ [ 2drop 1 ]
+}
+
+! Services
+{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
+ [
+ ! We return either self or nil
+ >r >r over window-focus r> r>
+ valid-service? [ drop ] [ 2drop f ] if
+ ]
+}
+
+{ "writeSelectionToPasteboard:types:" "bool" { "id" "SEL" "id" "id" }
+ [
+ CF>string-array NSStringPboardType swap member? [
+ >r drop window-focus gadget-selection dup [
+ r> set-pasteboard-string t
+ ] [
+ r> 2drop f
+ ] if
+ ] [
+ 3drop f
+ ] if
+ ]
+}
+
+{ "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" }
+ [
+ pasteboard-string dup [
+ >r drop window-focus r> swap user-input t
+ ] [
+ 3drop f
+ ] if
+ ]
+}
+
+! Text input
+{ "insertText:" "void" { "id" "SEL" "id" }
+ [ [ nip send-user-input ] ui-try ]
+}
+
+{ "hasMarkedText" "bool" { "id" "SEL" }
+ [ 2drop 0 ]
+}
+
+{ "markedRange" "NSRange" { "id" "SEL" }
+ [ 2drop 0 0 <NSRange> ]
+}
+
+{ "selectedRange" "NSRange" { "id" "SEL" }
+ [ 2drop 0 0 <NSRange> ]
+}
+
+{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
+ [ 2drop 2drop ]
+}
+
+{ "unmarkText" "void" { "id" "SEL" }
+ [ 2drop ]
+}
+
+{ "validAttributesForMarkedText" "id" { "id" "SEL" }
+ [ 2drop NSArray -> array ]
+}
+
+{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
+ [ 3drop f ]
+}
+
+{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" }
+ [ 3drop 0 ]
+}
+
+{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
+ [ 3drop 0 0 0 0 <NSRect> ]
+}
+
+{ "conversationIdentifier" "long" { "id" "SEL" }
+ [ drop alien-address ]
+}
+
+! Initialization
+{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
+ [
+ [
+ 2drop dup view-dim swap window (>>dim) yield
+ ] ui-try
+ ]
+}
+
+{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
+ [
+ rot drop
+ SUPER-> initWithFrame:pixelFormat:
+ dup dup add-resize-observer
+ ]
+}
+
+{ "dealloc" "void" { "id" "SEL" }
+ [
+ drop
+ dup unregister-window
+ dup remove-observer
+ SUPER-> dealloc
+ ]
+} ;
+
+: sync-refresh-to-screen ( GLView -- )
+ -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
+ CGLSetParameter drop ;
+
+: <FactorView> ( world -- view )
+ FactorView over rect-dim <GLView>
+ [ sync-refresh-to-screen ] keep
+ [ register-window ] keep ;
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "FactorWindowDelegate" }
+}
+
+{ "windowDidMove:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object
+ dup window-content-rect NSRect-x-y 2array
+ swap -> contentView window (>>window-loc)
+ ]
+}
+
+{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window focus-world
+ ]
+}
+
+{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
+ [
+ forget-rollover
+ 2nip -> object -> contentView window unfocus-world
+ ]
+}
+
+{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
+ [
+ 3drop t
+ ]
+}
+
+{ "windowWillClose:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window ungraft
+ ]
+} ;
+
+: install-window-delegate ( window -- )
+ FactorWindowDelegate install-delegate ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: accessors ui.gestures help.markup help.syntax strings kernel
+hashtables quotations words classes sequences namespaces
+arrays assocs ;
+IN: ui.commands
+
+: command-map-row ( gesture command -- seq )
+ [
+ [ gesture>string , ]
+ [
+ [ command-name , ]
+ [ command-word \ $link swap 2array , ]
+ [ command-description , ]
+ tri
+ ] bi*
+ ] { } make ;
+
+: command-map. ( alist -- )
+ [ command-map-row ] { } assoc>map
+ { "Shortcut" "Command" "Word" "Notes" }
+ [ \ $strong swap ] { } map>assoc prefix
+ $table ;
+
+: $command-map ( element -- )
+ [ second (command-name) " commands" append $heading ]
+ [
+ first2 swap command-map
+ [ blurb>> print-element ] [ commands>> command-map. ] bi
+ ] bi ;
+
+: $command ( element -- )
+ reverse first3 command-map
+ commands>> value-at gesture>string
+ $snippet ;
+
+HELP: +nullary+
+{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, the command does not take any inputs, and the value passed to " { $link invoke-command } " will be ignored. Otherwise, it takes one input." } ;
+
+HELP: +listener+
+{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, " { $link invoke-command } " will run the command in the listener. Otherwise it will run in the event loop." } ;
+
+HELP: +description+
+{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". The value is a string displayed as part of the command's documentation by " { $link $command-map } "." } ;
+
+HELP: invoke-command
+{ $values { "target" object } { "command" "a command" } }
+{ $description "Invokes a command on the given target object." } ;
+
+{ invoke-command +nullary+ } related-words
+
+HELP: command-name
+{ $values { "command" "a command" } { "str" "a string" } }
+{ $description "Outputs a human-readable name for the command." }
+{ $examples
+ { $example
+ "USING: io ui.commands ;"
+ "IN: scratchpad"
+ ": com-my-command ;"
+ "\\ com-my-command command-name write"
+ "My Command"
+ }
+} ;
+
+HELP: command-description
+{ $values { "command" "a command" } { "str/f" "a string or " { $link f } } }
+{ $description "Outputs the command's description." } ;
+
+{ command-description +description+ } related-words
+
+HELP: command-word
+{ $values { "command" "a command" } { "word" word } }
+{ $description "Outputs the word that will be executed by " { $link invoke-command } ". This is only used for documentation purposes." } ;
+
+HELP: command-map
+{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } }
+{ $description "Outputs a named command map defined on a class." }
+{ $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map."
+$nl
+"Command maps are created by calling " { $link <command-map> } " or " { $link define-command-map } "." } ;
+
+HELP: commands
+{ $values { "class" "a class word" } { "hash" hashtable } }
+{ $description "Outputs a hashtable mapping command map names to " { $link command-map } " instances." } ;
+
+HELP: define-command-map
+{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "pairs" "a sequence of gesture/word pairs" } }
+{ $description
+ "Defines a command map on the specified gadget class. The " { $snippet "specs" } " parameter is a sequence of pairs " { $snippet "{ gesture word }" } ". The words must be valid commands; see " { $link define-command } "."
+}
+{ $notes "Only one of " { $link define-command-map } " and " { $link set-gestures } " can be used on a given gadget class, since each word will overwrite the other word's definitions." } ;
+
+HELP: $command-map
+{ $values { "element" "a pair " { $snippet "{ class map }" } } }
+{ $description "Prints a command map, where the first element of the pair is a class word and the second is a command map name." } ;
+
+HELP: $command
+{ $values { "element" "a triple " { $snippet "{ class map command }" } } }
+{ $description "Prints the keyboard shortcut associated with " { $snippet "command" } " in the command map named " { $snippet "map" } " on the class " { $snippet "class" } "." } ;
+
+HELP: define-command
+{ $values { "word" word } { "hash" hashtable } }
+{ $description "Defines a command. The hashtable can contain the following keys:"
+ { $list
+ { { $link +nullary+ } " - if set to a true value, the word must have stack effect " { $snippet "( -- )" } "; otherwise it must have stack effect " { $snippet "( target -- )" } }
+ { { $link +listener+ } " - if set to a true value, the command will run in the listener" }
+ { { $link +description+ } " - can be set to a string description of the command" }
+ }
+} ;
+
+HELP: command-string
+{ $values { "gesture" "a gesture" } { "command" "a command" } { "string" string } }
+{ $description "Outputs a string containing the command name followed by the gesture." }
+{ $examples
+ { $example
+ "USING: io ui.commands ui.gestures ;"
+ "IN: scratchpad"
+ ": com-my-command ;"
+ "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write"
+ "My Command (C+s)"
+ }
+} ;
+
+ARTICLE: "ui-commands" "Commands"
+"Commands are an abstraction layered on top of gestures. Their main advantage is that they are identified by words and can be organized into " { $emphasis "command maps" } ". This allows easy construction of buttons and tool bars for invoking commands."
+{ $subsection define-command }
+"Command groups are defined on gadget classes:"
+{ $subsection define-command-map }
+"Commands can be introspected and invoked:"
+{ $subsection commands }
+{ $subsection command-map }
+{ $subsection invoke-command }
+"Gadgets for invoking commands are documented in " { $link "ui.gadgets.buttons" } "."
+$nl
+"When documenting gadgets, command documentation can be automatically generated:"
+{ $subsection $command-map }
+{ $subsection $command } ;
+
+ABOUT: "ui-commands"
--- /dev/null
+IN: ui.commands.tests
+USING: ui.commands ui.gestures tools.test help.markup io
+io.streams.string ;
+
+[ "A+a" ] [ T{ key-down f { A+ } "a" } gesture>string ] unit-test
+[ "b" ] [ T{ key-down f f "b" } gesture>string ] unit-test
+[ "Press Button 2" ] [ T{ button-down f f 2 } gesture>string ] unit-test
+
+: com-test-1 ;
+
+\ com-test-1 H{ } define-command
+
+[ [ 3 com-test-1 ] ] [ 3 \ com-test-1 command-quot ] unit-test
+
+: com-test-2 ;
+
+\ com-test-2 H{ { +nullary+ t } } define-command
+
+[ [ com-test-2 ] ] [ 3 \ com-test-2 command-quot ] unit-test
+
+SYMBOL: testing
+
+testing "testing" "hey" {
+ { T{ key-down f { C+ } "x" } com-test-1 }
+} define-command-map
+
+[ "C+x" ] [
+ [
+ { $command testing "testing" com-test-1 } print-element
+ ] with-string-writer
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays definitions kernel sequences strings
+math assocs words generic namespaces assocs quotations splitting
+ui.gestures unicode.case unicode.categories tr ;
+IN: ui.commands
+
+SYMBOL: +nullary+
+SYMBOL: +listener+
+SYMBOL: +description+
+
+PREDICATE: listener-command < word +listener+ word-prop ;
+
+GENERIC: invoke-command ( target command -- )
+
+GENERIC: command-name ( command -- str )
+
+TUPLE: command-map blurb commands ;
+
+GENERIC: command-description ( command -- str/f )
+
+GENERIC: command-word ( command -- word )
+
+: <command-map> ( blurb commands -- command-map )
+ { } like \ command-map boa ;
+
+: commands ( class -- hash )
+ dup "commands" word-prop [ ] [
+ H{ } clone [ "commands" set-word-prop ] keep
+ ] ?if ;
+
+: command-map ( group class -- command-map )
+ commands at ;
+
+: command-gestures ( class -- hash )
+ commands values [
+ [
+ commands>>
+ [ drop ] assoc-filter
+ [ [ invoke-command ] curry swap set ] assoc-each
+ ] each
+ ] H{ } make-assoc ;
+
+: update-gestures ( class -- )
+ dup command-gestures "gestures" set-word-prop ;
+
+: define-command-map ( class group blurb pairs -- )
+ <command-map>
+ swap pick commands set-at
+ update-gestures ;
+
+TR: convert-command-name "-" " " ;
+
+: (command-name) ( string -- newstring )
+ convert-command-name >title ;
+
+M: word command-name ( word -- str )
+ name>>
+ "com-" ?head drop
+ dup first Letter? [ rest ] unless
+ (command-name) ;
+
+M: word command-description ( word -- str )
+ +description+ word-prop ;
+
+: default-flags ( -- assoc )
+ H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
+
+: define-command ( word hash -- )
+ [ props>> ] [ default-flags swap assoc-union ] bi* update ;
+
+: command-quot ( target command -- quot )
+ dup 1quotation swap +nullary+ word-prop
+ [ nip ] [ curry ] if ;
+
+M: word invoke-command ( target command -- )
+ command-quot call ;
+
+M: word command-word ;
+
+M: f invoke-command ( target command -- ) 2drop ;
+
+: command-string ( gesture command -- string )
+ [
+ command-name %
+ gesture>string [ " (" % % ")" % ] when*
+ ] "" make ;
--- /dev/null
+UI command framework
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.syntax help.markup strings kernel alien opengl
+quotations ui.render io.styles freetype ;
+IN: ui.freetype
+
+HELP: freetype
+{ $values { "alien" alien } }
+{ $description "Outputs a native handle used by the FreeType library, initializing FreeType first if necessary." } ;
+
+HELP: open-fonts
+{ $var-description "Global variable. Hashtable mapping font descriptors to " { $link font } " instances." } ;
+
+{ font open-fonts open-font char-width string-width text-dim draw-string draw-text } related-words
+
+HELP: init-freetype
+{ $description "Initializes the FreeType library." }
+{ $notes "Do not call this word if you are using the UI." } ;
+
+HELP: font
+{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:"
+ { $list
+ { { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." }
+ { { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." }
+ { { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." }
+ }
+} ;
+
+HELP: close-freetype
+{ $description "Closes the FreeType library." }
+{ $notes "Do not call this word if you are using the UI." } ;
+
+HELP: open-face
+{ $values { "font" string } { "style" "one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
+{ $description "Loads a TrueType font with the requested logical font name and style." }
+{ $notes "This is a low-level word. Call " { $link open-font } " instead." } ;
+
+HELP: render-glyph
+{ $values { "font" font } { "char" "a non-negative integer" } { "bitmap" alien } }
+{ $description "Renders a character and outputs a pointer to the bitmap." } ;
+
+HELP: <char-sprite>
+{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
+{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
+
+HELP: (draw-string)
+{ $values { "open-font" font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
+{ $description "Draws a line of text." }
+{ $notes "This is a low-level word, UI code should use " { $link draw-string } " or " { $link draw-text } " instead." }
+{ $side-effects "sprites" } ;
+
+HELP: run-char-widths
+{ $values { "open-font" font } { "string" string } { "widths" "a sequence of integers" } }
+{ $description "Outputs a sequence of x co-ordinates of the midpoint of each character in the string." }
+{ $notes "This word is used to convert x offsets to document locations, for example when the user moves the caret by clicking the mouse." } ;
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors alien.c-types arrays io kernel libc
+math math.vectors namespaces opengl opengl.gl prettyprint assocs
+sequences io.files io.styles continuations freetype
+ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
+locals ;
+
+IN: ui.freetype
+
+TUPLE: freetype-renderer ;
+
+SYMBOL: open-fonts
+
+: freetype-error ( n -- )
+ zero? [ "FreeType error" throw ] unless ;
+
+DEFER: freetype
+
+: init-freetype ( -- )
+ global [
+ f <void*> dup FT_Init_FreeType freetype-error
+ *void* \ freetype set
+ H{ } clone open-fonts set
+ ] bind ;
+
+: freetype ( -- alien )
+ \ freetype get-global expired? [ init-freetype ] when
+ \ freetype get-global ;
+
+TUPLE: font < identity-tuple
+ascent descent height handle widths ;
+
+M: font hashcode* drop font hashcode* ;
+
+: close-font ( font -- ) font-handle FT_Done_Face ;
+
+: close-freetype ( -- )
+ global [
+ open-fonts [ [ drop close-font ] assoc-each f ] change
+ freetype [ FT_Done_FreeType f ] change
+ ] bind ;
+
+M: freetype-renderer free-fonts ( world -- )
+ [ handle>> select-gl-context ]
+ [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
+
+: ttf-name ( font style -- name )
+ 2array H{
+ { { "monospace" plain } "VeraMono" }
+ { { "monospace" bold } "VeraMoBd" }
+ { { "monospace" bold-italic } "VeraMoBI" }
+ { { "monospace" italic } "VeraMoIt" }
+ { { "sans-serif" plain } "Vera" }
+ { { "sans-serif" bold } "VeraBd" }
+ { { "sans-serif" bold-italic } "VeraBI" }
+ { { "sans-serif" italic } "VeraIt" }
+ { { "serif" plain } "VeraSe" }
+ { { "serif" bold } "VeraSeBd" }
+ { { "serif" bold-italic } "VeraBI" }
+ { { "serif" italic } "VeraIt" }
+ } at ;
+
+: ttf-path ( name -- string )
+ "resource:fonts/" swap ".ttf" 3append ;
+
+: (open-face) ( path length -- face )
+ #! We use FT_New_Memory_Face, not FT_New_Face, since
+ #! FT_New_Face only takes an ASCII path name and causes
+ #! problems on localized versions of Windows
+ [ freetype ] 2dip 0 f <void*> [
+ FT_New_Memory_Face freetype-error
+ ] keep *void* ;
+
+: open-face ( font style -- face )
+ ttf-name ttf-path malloc-file-contents (open-face) ;
+
+SYMBOL: dpi
+
+72 dpi set-global
+
+: ft-floor -6 shift ; inline
+
+: ft-ceil 63 + -64 bitand -6 shift ; inline
+
+: font-units>pixels ( n font -- n )
+ face-size face-size-y-scale FT_MulFix ;
+
+: init-ascent ( font face -- font )
+ dup face-y-max swap font-units>pixels >>ascent ; inline
+
+: init-descent ( font face -- font )
+ dup face-y-min swap font-units>pixels >>descent ; inline
+
+: init-font ( font -- font )
+ dup handle>> init-ascent
+ dup handle>> init-descent
+ dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
+
+: set-char-size ( handle size -- )
+ 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
+
+: <font> ( handle -- font )
+ font new
+ H{ } clone >>widths
+ over first2 open-face >>handle
+ dup handle>> rot third set-char-size
+ init-font ;
+
+M: freetype-renderer open-font ( font -- open-font )
+ freetype drop open-fonts get [ <font> ] cache ;
+
+: load-glyph ( font char -- glyph )
+ >r font-handle dup r> 0 FT_Load_Char
+ freetype-error face-glyph ;
+
+: char-width ( open-font char -- w )
+ over font-widths [
+ dupd load-glyph glyph-hori-advance ft-ceil
+ ] cache nip ;
+
+M: freetype-renderer string-width ( open-font string -- w )
+ 0 -rot [ char-width + ] with each ;
+
+M: freetype-renderer string-height ( open-font string -- h )
+ drop font-height ;
+
+: glyph-size ( glyph -- dim )
+ dup glyph-hori-advance ft-ceil
+ swap glyph-height ft-ceil 2array ;
+
+: render-glyph ( font char -- bitmap )
+ load-glyph dup
+ FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
+
+:: copy-pixel ( i j bitmap texture -- i j )
+ 255 j texture set-char-nth
+ i bitmap char-nth j 1 + texture set-char-nth
+ i 1 + j 2 + ; inline
+
+:: (copy-row) ( i j bitmap texture end -- )
+ i end < [
+ i j bitmap texture copy-pixel
+ bitmap texture end (copy-row)
+ ] when ; inline recursive
+
+:: copy-row ( i j bitmap texture width width2 -- i j )
+ i j bitmap texture i width + (copy-row)
+ i width +
+ j width2 + ; inline
+
+:: copy-bitmap ( glyph texture -- )
+ [let* | bitmap [ glyph glyph-bitmap-buffer ]
+ rows [ glyph glyph-bitmap-rows ]
+ width [ glyph glyph-bitmap-width ]
+ width2 [ width next-power-of-2 2 * ] |
+ 0 0
+ rows [ bitmap texture width width2 copy-row ] times
+ 2drop
+ ] ;
+
+: bitmap>texture ( glyph sprite -- id )
+ tuck sprite-size2 * 2 * [
+ [ copy-bitmap ] keep gray-texture
+ ] with-malloc ;
+
+: glyph-texture-loc ( glyph font -- loc )
+ over glyph-hori-bearing-x ft-floor -rot
+ font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
+
+: glyph-texture-size ( glyph -- dim )
+ [ glyph-bitmap-width next-power-of-2 ]
+ [ glyph-bitmap-rows next-power-of-2 ]
+ bi 2array ;
+
+: <char-sprite> ( open-font char -- sprite )
+ over >r render-glyph dup r> glyph-texture-loc
+ over glyph-size pick glyph-texture-size <sprite>
+ [ bitmap>texture ] keep [ init-sprite ] keep ;
+
+:: char-sprite ( open-font sprites char -- sprite )
+ char sprites [ open-font swap <char-sprite> ] cache ;
+
+: draw-char ( open-font sprites char loc -- )
+ GL_MODELVIEW [
+ 0 0 glTranslated
+ char-sprite sprite-dlist glCallList
+ ] do-matrix ;
+
+: char-widths ( open-font string -- widths )
+ [ char-width ] with { } map-as ;
+
+: scan-sums ( seq -- seq' )
+ 0 [ + ] accumulate nip ;
+
+:: (draw-string) ( open-font sprites string loc -- )
+ GL_TEXTURE_2D [
+ loc [
+ string open-font string char-widths scan-sums [
+ [ open-font sprites ] 2dip draw-char
+ ] 2each
+ ] with-translation
+ ] do-enabled ;
+
+: font-sprites ( font world -- open-font sprites )
+ world-fonts [ open-font H{ } clone 2array ] cache first2 ;
+
+M: freetype-renderer draw-string ( font string loc -- )
+ >r >r world get font-sprites r> r> (draw-string) ;
+
+: run-char-widths ( open-font string -- widths )
+ char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
+
+M: freetype-renderer x>offset ( x open-font string -- n )
+ dup >r run-char-widths [ <= ] with find drop
+ [ r> drop ] [ r> length ] if* ;
+
+T{ freetype-renderer } font-renderer set-global
--- /dev/null
+UI text rendering implementation based on FreeType
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets models ;
+IN: ui.gadgets.books
+
+HELP: book
+{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
+$nl
+"Books are created by calling " { $link <book> } "." } ;
+
+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 " } ;
+
+ARTICLE: "ui-book-layout" "Book layouts"
+"Books can contain any number of children, and display one child at a time."
+{ $subsection book }
+{ $subsection <book> } ;
+
+ABOUT: "ui-book-layout"
--- /dev/null
+IN: ui.gadgets.books.tests
+USING: tools.test ui.gadgets.books ;
+
+\ <book> must-infer
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
+IN: ui.gadgets.books
+
+TUPLE: book < gadget ;
+
+: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
+
+: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
+
+M: book model-changed ( model book -- )
+ nip
+ dup hide-all
+ dup current-page show-gadget
+ relayout ;
+
+: new-book ( pages model class -- book )
+ new-gadget
+ swap >>model
+ swap add-gadgets ; inline
+
+: <book> ( pages model -- book ) book new-book ;
+
+M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
+
+M: book layout* ( book -- )
+ [ dim>> ] [ children>> ] bi [ (>>dim) ] with each ;
+
+M: book focusable-child* ( book -- child/t ) current-page ;
--- /dev/null
+Book gadget displays one child at a time
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets math ;
+IN: ui.gadgets.borders
+
+HELP: border
+{ $class-description "A border gadget contains a single child and centers it, with a fixed-width border. Borders are created by calling " { $link <border> } "." } ;
+
+HELP: <border>
+{ $values { "child" gadget } { "gap" integer } { "border" "a new " { $link border } } }
+{ $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."
+{ $subsection border }
+{ $subsection <border> } ;
+
+ABOUT: "ui.gadgets.borders"
--- /dev/null
+IN: ui.gadgets.borders.tests
+USING: tools.test accessors namespaces kernel
+ui.gadgets ui.gadgets.borders math.geometry.rect ;
+
+[ { 110 210 } ] [ <gadget> { 100 200 } >>dim 5 <border> pref-dim ] unit-test
+
+[ ] [ <gadget> { 100 200 } >>dim "g" set ] unit-test
+
+[ ] [ "g" get 0 <border> { 100 200 } >>dim "b" set ] unit-test
+
+[ T{ rect f { 0 0 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "g" get 5 <border> { 210 210 } >>dim "b" set ] unit-test
+
+[ T{ rect f { 55 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "b" get { 0 0 } >>align drop ] unit-test
+
+[ { 5 5 } ] [ "b" get { 100 200 } border-loc ] unit-test
+
+[ T{ rect f { 5 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
+
+[ ] [ "b" get { 1 1 } >>fill drop ] unit-test
+
+[ T{ rect f { 5 5 } { 200 200 } } ] [ "b" get border-child-rect ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ui.gadgets kernel math
+namespaces vectors sequences math.vectors math.geometry.rect ;
+IN: ui.gadgets.borders
+
+TUPLE: border < gadget
+{ size initial: { 0 0 } }
+{ fill initial: { 0 0 } }
+{ align initial: { 1/2 1/2 } } ;
+
+: new-border ( child class -- border )
+ new-gadget [ swap add-gadget drop ] keep ; inline
+
+: <border> ( child gap -- border )
+ swap border new-border
+ swap dup 2array >>size ;
+
+M: border pref-dim*
+ [ size>> 2 v*n ] keep
+ gadget-child pref-dim v+ ;
+
+: border-major-dim ( border -- dim )
+ [ dim>> ] [ size>> 2 v*n ] bi v- ;
+
+: border-minor-dim ( border -- dim )
+ gadget-child pref-dim ;
+
+: scale ( a b s -- c )
+ tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
+
+: border-dim ( border -- dim )
+ [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
+
+: border-loc ( border dim -- loc )
+ [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
+ v- v* v+ [ >fixnum ] map ;
+
+: border-child-rect ( border -- rect )
+ dup border-dim [ border-loc ] keep <rect> ;
+
+M: border layout*
+ dup border-child-rect swap gadget-child
+ over loc>> over set-rect-loc
+ swap dim>> swap (>>dim) ;
+
+M: border focusable-child*
+ gadget-child ;
--- /dev/null
+Border gadget adds padding around a child
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets ui.gadgets.labels
+ui.render kernel models classes ;
+IN: ui.gadgets.buttons
+
+HELP: button
+{ $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation."
+$nl
+"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "."
+$nl
+"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
+
+HELP: <button>
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
+{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's only child." } ;
+
+HELP: <roll-button>
+{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
+{ $description "Creates a new " { $link button } " which is displayed with a solid border when it is under the mouse, informing the user that the gadget is clickable." } ;
+
+HELP: <bevel-button>
+{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
+{ $description "Creates a new " { $link button } " with a shaded border which is always visible. The button appearance changes in response to mouse gestures using a " { $link button-paint } "." } ;
+
+HELP: <repeat-button>
+{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" repeat-button } }
+{ $description "Creates a new " { $link button } " derived from a " { $link <bevel-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ;
+
+HELP: button-paint
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
+ { $list
+ { { $link button-paint-plain } " - the button is inactive" }
+ { { $link button-paint-rollover } " - the button is under the mouse" }
+ { { $link button-paint-pressed } " - the button is under the mouse and a mouse button is held down" }
+ { { $link button-paint-selected } " - the button is selected (see " { $link <toggle-buttons> } }
+ }
+"The " { $link <roll-button> } " and " { $link <bevel-button> } " words create " { $link button } " instances with specific " { $link button-paint } "." } ;
+
+HELP: <toggle-button>
+{ $values { "model" model } { "value" object } { "label" "a label specifier" } { "gadget" gadget } }
+{ $description
+ "Creates a " { $link <bevel-button> } " which sets the model's value to " { $snippet "value" } " when pressed. After being pressed, the button becomes selected until the value of the model changes again."
+}
+{ $notes "Typically a row of radio controls should be built together using " { $link <toggle-buttons> } "." } ;
+
+HELP: <toggle-buttons>
+{ $values { "model" model } { "assoc" "an association list mapping labels to objects" } { "gadget" gadget } }
+{ $description "Creates a row of labelled " { $link <toggle-button> } " gadgets which change the value of the model." } ;
+
+HELP: <command-button>
+{ $values { "target" object } { "gesture" "a gesture" } { "command" "a command" } { "button" "a new " { $link button } } }
+{ $description "Creates a " { $link <bevel-button> } " which invokes the command on " { $snippet "target" } " when clicked." } ;
+
+HELP: <toolbar>
+{ $values { "target" object } { "toolbar" gadget } }
+{ $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."
+{ $subsection button }
+"There are many ways to create a new button:"
+{ $subsection <button> }
+{ $subsection <roll-button> }
+{ $subsection <bevel-button> }
+{ $subsection <repeat-button> }
+"Gadgets for invoking commands:"
+{ $subsection <command-button> }
+{ $subsection <toolbar> }
+"A radio box is a row of buttons for choosing amongst several distinct possibilities:"
+{ $subsection <toggle-buttons> }
+"Button appearance can be customized:"
+{ $subsection button-paint }
+"Button constructors take " { $emphasis "label specifiers" } " as input. A label specifier is either a string, an array of strings, a gadget or " { $link f } "."
+{ $see-also <command-button> "ui-commands" } ;
--- /dev/null
+IN: ui.gadgets.buttons.tests
+USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
+ui.gadgets tools.test namespaces sequences kernel models ;
+
+TUPLE: foo-gadget ;
+
+: com-foo-a ;
+
+: com-foo-b ;
+
+\ foo-gadget "toolbar" f {
+ { f com-foo-a }
+ { f com-foo-b }
+} define-command-map
+
+T{ foo-gadget } <toolbar> "t" set
+
+[ 2 ] [ "t" get gadget-children length ] unit-test
+[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test
+
+[ ] [
+ 2 <model> {
+ { 0 "atheist" }
+ { 1 "christian" }
+ { 2 "muslim" }
+ { 3 "jewish" }
+ } <radio-buttons> "religion" set
+] unit-test
+
+\ <radio-buttons> must-infer
+
+\ <toggle-buttons> must-infer
+
+\ <checkbox> must-infer
+
+[ 0 ] [
+ "religion" get gadget-child radio-control-value
+] unit-test
+
+[ 2 ] [
+ "religion" get gadget-child control-value
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel math models namespaces sequences
+ strings quotations assocs combinators classes colors
+ classes.tuple opengl math.vectors
+ ui.commands ui.gadgets ui.gadgets.borders
+ ui.gadgets.labels ui.gadgets.theme
+ ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ ui.render math.geometry.rect ;
+
+IN: ui.gadgets.buttons
+
+TUPLE: button < border pressed? selected? quot ;
+
+: buttons-down? ( -- ? )
+ hand-buttons get-global empty? not ;
+
+: button-rollover? ( button -- ? )
+ hand-gadget get-global child? ;
+
+: mouse-clicked? ( gadget -- ? )
+ hand-clicked get-global child? ;
+
+: button-update ( button -- )
+ dup mouse-clicked?
+ over button-rollover? and
+ buttons-down? and
+ over set-button-pressed?
+ relayout-1 ;
+
+: if-clicked ( button quot -- )
+ >r dup button-update dup button-rollover? r> [ drop ] if ;
+
+: button-clicked ( button -- )
+ dup button-quot if-clicked ;
+
+button H{
+ { T{ button-up } [ button-clicked ] }
+ { T{ button-down } [ button-update ] }
+ { T{ mouse-leave } [ button-update ] }
+ { T{ mouse-enter } [ button-update ] }
+} set-gestures
+
+: new-button ( label quot class -- button )
+ [ swap >label ] dip new-border swap >>quot ; inline
+
+: <button> ( label quot -- button )
+ button new-button ;
+
+TUPLE: button-paint plain rollover pressed selected ;
+
+C: <button-paint> button-paint
+
+: find-button ( gadget -- button )
+ [ [ button? ] is? ] find-parent ;
+
+: button-paint ( button paint -- button paint )
+ over find-button {
+ { [ dup pressed?>> ] [ drop pressed>> ] }
+ { [ dup selected?>> ] [ drop selected>> ] }
+ { [ dup button-rollover? ] [ drop rollover>> ] }
+ [ drop plain>> ]
+ } cond ;
+
+M: button-paint draw-interior
+ button-paint draw-interior ;
+
+M: button-paint draw-boundary
+ button-paint draw-boundary ;
+
+: roll-button-theme ( button -- button )
+ f black <solid> dup f <button-paint> >>boundary
+ { 0 1/2 } >>align ; inline
+
+: <roll-button> ( label quot -- button )
+ <button> roll-button-theme ;
+
+: <bevel-button-paint> ( -- paint )
+ plain-gradient
+ rollover-gradient
+ pressed-gradient
+ selected-gradient
+ <button-paint> ;
+
+: bevel-button-theme ( gadget -- gadget )
+ <bevel-button-paint> >>interior
+ { 5 5 } >>size
+ faint-boundary ; inline
+
+: <bevel-button> ( label quot -- button )
+ <button> bevel-button-theme ;
+
+TUPLE: repeat-button < button ;
+
+repeat-button H{
+ { T{ drag } [ button-clicked ] }
+} set-gestures
+
+: <repeat-button> ( label quot -- button )
+ #! Button that calls the quotation every 100ms as long as
+ #! the mouse is held down.
+ repeat-button new-button bevel-button-theme ;
+
+TUPLE: checkmark-paint color ;
+
+C: <checkmark-paint> checkmark-paint
+
+M: checkmark-paint draw-interior
+ checkmark-paint-color set-color
+ origin get [
+ rect-dim
+ { 0 0 } over gl-line
+ dup { 0 1 } v* swap { 1 0 } v* gl-line
+ ] with-translation ;
+
+: checkmark-theme ( gadget -- )
+ f
+ f
+ black <solid>
+ black <checkmark-paint>
+ <button-paint>
+ over set-gadget-interior
+ black <solid>
+ swap set-gadget-boundary ;
+
+: <checkmark> ( -- gadget )
+ <gadget>
+ dup checkmark-theme
+ { 14 14 } over (>>dim) ;
+
+: toggle-model ( model -- )
+ [ not ] change-model ;
+
+: checkbox-theme ( gadget -- gadget )
+ f >>interior
+ { 5 5 } >>gap
+ 1/2 >>align ; inline
+
+TUPLE: checkbox < button ;
+
+: <checkbox> ( model label -- checkbox )
+ <checkmark> label-on-right checkbox-theme
+ [ model>> toggle-model ]
+ checkbox new-button
+ swap >>model ;
+
+M: checkbox model-changed
+ swap model-value over set-button-selected? relayout-1 ;
+
+TUPLE: radio-paint color ;
+
+C: <radio-paint> radio-paint
+
+M: radio-paint draw-interior
+ radio-paint-color set-color
+ origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
+
+M: radio-paint draw-boundary
+ radio-paint-color set-color
+ origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
+
+: radio-knob-theme ( gadget -- )
+ f
+ f
+ black <radio-paint>
+ black <radio-paint>
+ <button-paint>
+ over set-gadget-interior
+ black <radio-paint>
+ swap set-gadget-boundary ;
+
+: <radio-knob> ( -- gadget )
+ <gadget>
+ dup radio-knob-theme
+ { 16 16 } over (>>dim) ;
+
+TUPLE: radio-control < button value ;
+
+: <radio-control> ( value model label -- control )
+ [ [ value>> ] keep set-control-value ]
+ radio-control new-button
+ swap >>model
+ swap >>value ; inline
+
+M: radio-control model-changed
+ swap model-value
+ over radio-control-value =
+ over set-button-selected?
+ relayout-1 ;
+
+: <radio-controls> ( parent model assoc quot -- parent )
+ #! quot has stack effect ( value model label -- )
+ swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
+
+: radio-button-theme ( gadget -- gadget )
+ { 5 5 } >>gap
+ 1/2 >>align ; inline
+
+: <radio-button> ( value model label -- gadget )
+ <radio-knob> label-on-right radio-button-theme <radio-control> ;
+
+: <radio-buttons> ( model assoc -- gadget )
+ <filled-pile>
+ -rot
+ [ <radio-button> ] <radio-controls>
+ { 5 5 } >>gap ;
+
+: <toggle-button> ( value model label -- gadget )
+ <radio-control> bevel-button-theme ;
+
+: <toggle-buttons> ( model assoc -- gadget )
+ <shelf>
+ -rot
+ [ <toggle-button> ] <radio-controls> ;
+
+: command-button-quot ( target command -- quot )
+ [ invoke-command drop ] 2curry ;
+
+: <command-button> ( target gesture command -- button )
+ [ command-string ] keep
+ swapd
+ command-button-quot
+ <bevel-button> ;
+
+: <toolbar> ( target -- toolbar )
+ <shelf>
+ swap
+ "toolbar" over class command-map commands>> swap
+ [ -rot <command-button> add-gadget ] curry assoc-each ;
--- /dev/null
+Button gadgets invoke commands when clicked
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib
+ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
+classes.tuple colors ;
+IN: ui.gadgets.canvas
+
+TUPLE: canvas < gadget dlist ;
+
+: <canvas> ( -- canvas )
+ canvas new-gadget
+ black solid-interior ;
+
+: delete-canvas-dlist ( canvas -- )
+ dup find-gl-context
+ dup canvas-dlist [ delete-dlist ] when*
+ f swap set-canvas-dlist ;
+
+: make-canvas-dlist ( canvas quot -- dlist )
+ over >r GL_COMPILE swap make-dlist dup r>
+ set-canvas-dlist ;
+
+: cache-canvas-dlist ( canvas quot -- dlist )
+ over canvas-dlist dup
+ [ 2nip ] [ drop make-canvas-dlist ] if ; inline
+
+: draw-canvas ( canvas quot -- )
+ origin get [
+ cache-canvas-dlist glCallList
+ ] with-translation ; inline
+
+M: canvas ungraft* delete-canvas-dlist ;
--- /dev/null
+
+USING: kernel combinators sequences opengl.gl
+ ui.render ui.gadgets ui.gadgets.slate
+ accessors ;
+
+IN: ui.gadgets.cartesian
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;
+
+: init-cartesian ( cartesian -- cartesian )
+ init-slate
+ -10 >>x-min
+ 10 >>x-max
+ -10 >>y-min
+ 10 >>y-max
+ -1 >>z-min
+ 1 >>z-max ;
+
+: <cartesian> ( -- cartesian ) cartesian new init-cartesian ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: cartesian establish-coordinate-system ( cartesian -- cartesian )
+ dup
+ {
+ [ x-min>> ] [ x-max>> ]
+ [ y-min>> ] [ y-max>> ]
+ [ z-min>> ] [ z-max>> ]
+ }
+ cleave
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ;
+: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ;
+: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: documents help.markup help.syntax ui.gadgets
+ui.gadgets.scrollers models strings ui.commands ;
+IN: ui.gadgets.editors
+
+HELP: editor
+{ $class-description "An editor is a control for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
+$nl
+"Editors have the following slots:"
+{ $list
+ { { $link editor-font } " - a font specifier." }
+ { { $link editor-color } " - text color specifier." }
+ { { $link editor-caret-color } " - caret color specifier." }
+ { { $link editor-selection-color } " - selection background color specifier." }
+ { { $link editor-caret } " - a model storing a line/column pair." }
+ { { $link editor-mark } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
+ { { $link editor-focused? } " - a boolean." }
+} } ;
+
+HELP: <editor>
+{ $values { "editor" "a new " { $link editor } } }
+{ $description "Creates a new " { $link editor } " with an empty document." } ;
+
+HELP: editor-caret ( editor -- caret )
+{ $values { "editor" editor } { "caret" model } }
+{ $description "Outputs a " { $link model } " holding the current caret location." } ;
+
+{ editor-caret editor-caret* editor-mark editor-mark* } related-words
+
+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 ( editor -- mark )
+{ $values { "editor" editor } { "mark" model } }
+{ $description "Outputs a " { $link model } " holding the current mark location." } ;
+
+HELP: editor-mark*
+{ $values { "editor" editor } { "loc" "a pair of integers" } }
+{ $description "Outputs the current mark location as a line/column number pair." } ;
+
+HELP: change-caret
+{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
+{ $description "Applies a quotation to the current caret location and moves the caret to the location output by the quotation." } ;
+
+{ change-caret change-caret&mark mark>caret } related-words
+
+HELP: mark>caret
+{ $values { "editor" editor } }
+{ $description "Moves the mark to the caret location, effectively deselecting any selected text." } ;
+
+HELP: change-caret&mark
+{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
+{ $description "Applies a quotation to the current caret location and moves the caret and the mark to the location output by the quotation." } ;
+
+HELP: point>loc
+{ $values { "point" "a pair of integers" } { "editor" editor } { "loc" "a pair of integers" } }
+{ $description "Converts a point to a line/column number pair." } ;
+
+HELP: scroll>caret
+{ $values { "editor" editor } }
+{ $description "Ensures that the caret becomes visible in a " { $link scroller } " containing the editor. Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
+
+HELP: remove-selection
+{ $values { "editor" editor } }
+{ $description "Removes currently selected text from the editor's " { $link document } "." } ;
+
+HELP: editor-string
+{ $values { "editor" editor } { "string" string } }
+{ $description "Outputs the contents of the editor's " { $link document } " as a string. Lines are separated by " { $snippet "\\n" } "." } ;
+
+HELP: set-editor-string
+{ $values { "string" string } { "editor" editor } }
+{ $description "Sets the contents of the editor's " { $link document } " to a string, which may use either " { $snippet "\\n" } ", " { $snippet "\\r\\n" } " or " { $snippet "\\r" } " line separators." } ;
+
+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-caret* }
+{ $subsection editor-mark }
+{ $subsection editor-mark* }
+{ $subsection change-caret }
+{ $subsection change-caret&mark }
+{ $subsection mark>caret }
+"Getting the selected text:"
+{ $subsection gadget-selection? }
+{ $subsection gadget-selection }
+"Removing selected text:"
+{ $subsection remove-selection }
+"Scrolling to the caret location:"
+{ $subsection scroll>caret }
+"Use " { $link user-input* } " to change selected text." ;
+
+ARTICLE: "gadgets-editors" "Editor gadgets"
+"An editor edits a multi-line passage of text."
+{ $command-map editor "general" }
+{ $command-map editor "caret-motion" }
+{ $command-map editor "selection" }
+{ $heading "Editor words" }
+{ $subsection editor }
+{ $subsection <editor> }
+{ $subsection editor-string }
+{ $subsection set-editor-string }
+{ $subsection "gadgets-editors-selection" }
+{ $subsection "documents" }
+{ $subsection "document-locs-elts" } ;
+
+ABOUT: "gadgets-editors"
--- /dev/null
+USING: accessors ui.gadgets.editors tools.test kernel io
+io.streams.plain definitions namespaces ui.gadgets
+ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui
+models ;
+
+[ "foo bar" ] [
+ <editor> "editor" set
+ "editor" get [
+ "foo bar" "editor" get set-editor-string
+ "editor" get T{ one-line-elt } select-elt
+ "editor" get gadget-selection
+ ] with-grafted-gadget
+] unit-test
+
+[ "baz quux" ] [
+ <editor> "editor" set
+ "editor" get [
+ "foo bar\nbaz quux" "editor" get set-editor-string
+ "editor" get T{ 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
+ 4 hand-click# set
+ "editor" get position-caret
+ ] with-grafted-gadget
+] unit-test
+
+[ "bar" ] [
+ <editor> "editor" set
+ "editor" get [
+ "bar\nbaz quux" "editor" get set-editor-string
+ { 0 3 } "editor" get editor-caret set-model
+ "editor" get select-word
+ "editor" get gadget-selection
+ ] with-grafted-gadget
+] unit-test
+
+\ <editor> must-infer
+
+"hello" <model> <field> "field" set
+
+"field" get [
+ [ "hello" ] [ "field" get field-model>> model-value ] unit-test
+] with-grafted-gadget
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays documents io kernel math models
+namespaces opengl opengl.gl sequences strings io.styles
+math.vectors sorting colors combinators assocs math.order
+ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
+ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
+math.geometry.rect ;
+IN: ui.gadgets.editors
+
+TUPLE: editor < gadget
+font color caret-color selection-color
+caret mark
+focused? ;
+
+: <loc> ( -- loc ) { 0 0 } <model> ;
+
+: init-editor-locs ( editor -- editor )
+ <loc> >>caret
+ <loc> >>mark ; inline
+
+: editor-theme ( editor -- editor )
+ black >>color
+ red >>caret-color
+ selection-color >>selection-color
+ monospace-font >>font ; inline
+
+: new-editor ( class -- editor )
+ new-gadget
+ <document> >>model
+ init-editor-locs
+ editor-theme ; inline
+
+: <editor> ( -- editor )
+ editor new-editor ;
+
+: activate-editor-model ( editor model -- )
+ 2dup add-connection
+ dup activate-model
+ swap gadget-model add-loc ;
+
+: deactivate-editor-model ( editor model -- )
+ 2dup remove-connection
+ dup deactivate-model
+ swap gadget-model remove-loc ;
+
+M: editor graft*
+ dup
+ dup editor-caret activate-editor-model
+ dup editor-mark activate-editor-model ;
+
+M: editor ungraft*
+ dup
+ dup editor-caret deactivate-editor-model
+ dup editor-mark deactivate-editor-model ;
+
+: editor-caret* ( editor -- loc ) editor-caret model-value ;
+
+: editor-mark* ( editor -- loc ) editor-mark model-value ;
+
+: set-caret ( loc editor -- )
+ [ gadget-model validate-loc ] keep
+ editor-caret set-model ;
+
+: change-caret ( editor quot -- )
+ over >r >r dup editor-caret* swap gadget-model r> call r>
+ set-caret ; inline
+
+: mark>caret ( editor -- )
+ dup editor-caret* swap editor-mark set-model ;
+
+: change-caret&mark ( editor quot -- )
+ over >r change-caret r> mark>caret ; inline
+
+: editor-line ( n editor -- str ) control-value nth ;
+
+: editor-font* ( editor -- font ) editor-font open-font ;
+
+: line-height ( editor -- n )
+ editor-font* "" string-height ;
+
+: y>line ( y editor -- line# )
+ [ line-height / >fixnum ] keep gadget-model validate-line ;
+
+: point>loc ( point editor -- loc )
+ [
+ >r first2 r> tuck y>line dup ,
+ >r dup editor-font* r>
+ rot editor-line x>offset ,
+ ] { } make ;
+
+: clicked-loc ( editor -- loc )
+ [ hand-rel ] keep point>loc ;
+
+: click-loc ( editor model -- )
+ >r clicked-loc r> set-model ;
+
+: focus-editor ( editor -- )
+ t over set-editor-focused? relayout-1 ;
+
+: unfocus-editor ( editor -- )
+ f over set-editor-focused? relayout-1 ;
+
+: (offset>x) ( font col# str -- x )
+ swap head-slice string-width ;
+
+: offset>x ( col# line# editor -- x )
+ [ editor-line ] keep editor-font* -rot (offset>x) ;
+
+: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
+
+: line>y ( lines# editor -- y )
+ line-height * ;
+
+: caret-loc ( editor -- loc )
+ [ editor-caret* ] keep 2dup loc>x
+ rot first rot line>y 2array ;
+
+: caret-dim ( editor -- dim )
+ line-height 0 swap 2array ;
+
+: scroll>caret ( editor -- )
+ dup gadget-graft-state second [
+ dup caret-loc over caret-dim { 1 0 } v+ <rect>
+ over scroll>rect
+ ] when drop ;
+
+: draw-caret ( -- )
+ editor get editor-focused? [
+ editor get
+ dup editor-caret-color set-color
+ dup caret-loc origin get v+
+ swap caret-dim over v+
+ [ { 0.5 -0.5 } v+ ] bi@ gl-line
+ ] when ;
+
+: line-translation ( n -- loc )
+ editor get line-height * 0.0 swap 2array ;
+
+: translate-lines ( n -- )
+ line-translation gl-translate ;
+
+: draw-line ( editor str -- )
+ >r editor-font r> { 0 0 } draw-string ;
+
+: first-visible-line ( editor -- n )
+ clip get rect-loc second origin get second -
+ swap y>line ;
+
+: last-visible-line ( editor -- n )
+ clip get rect-extent nip second origin get second -
+ swap y>line 1+ ;
+
+: with-editor ( editor quot -- )
+ [
+ swap
+ dup first-visible-line \ first-visible-line set
+ dup last-visible-line \ last-visible-line set
+ dup gadget-model document set
+ editor set
+ call
+ ] with-scope ; inline
+
+: visible-lines ( editor -- seq )
+ \ first-visible-line get
+ \ last-visible-line get
+ rot control-value <slice> ;
+
+: with-editor-translation ( n quot -- )
+ >r line-translation origin get v+ r> with-translation ;
+ inline
+
+: draw-lines ( -- )
+ \ first-visible-line get [
+ editor get dup editor-color set-color
+ dup visible-lines
+ [ draw-line 1 translate-lines ] with each
+ ] with-editor-translation ;
+
+: selection-start/end ( editor -- start end )
+ dup editor-mark* swap editor-caret* sort-pair ;
+
+: (draw-selection) ( x1 x2 -- )
+ 2dup = [ 2 + ] when
+ 0.0 swap editor get line-height glRectd ;
+
+: draw-selected-line ( start end n -- )
+ [ start/end-on-line ] keep tuck
+ >r >r editor get offset>x r> r>
+ editor get offset>x
+ (draw-selection) ;
+
+: draw-selection ( -- )
+ editor get editor-selection-color set-color
+ editor get selection-start/end
+ over first [
+ 2dup [
+ >r 2dup r> draw-selected-line
+ 1 translate-lines
+ ] each-line 2drop
+ ] with-editor-translation ;
+
+M: editor draw-gadget*
+ [ draw-selection draw-lines draw-caret ] with-editor ;
+
+M: editor pref-dim*
+ dup editor-font* swap control-value text-dim ;
+
+: contents-changed ( model editor -- )
+ swap
+ over caret>> [ over validate-loc ] (change-model)
+ over mark>> [ over validate-loc ] (change-model)
+ drop relayout ;
+
+: caret/mark-changed ( model editor -- )
+ nip [ relayout-1 ] [ scroll>caret ] bi ;
+
+M: editor model-changed
+ {
+ { [ 2dup model>> eq? ] [ contents-changed ] }
+ { [ 2dup caret>> eq? ] [ caret/mark-changed ] }
+ { [ 2dup mark>> eq? ] [ caret/mark-changed ] }
+ } cond ;
+
+M: editor gadget-selection?
+ selection-start/end = not ;
+
+M: editor gadget-selection
+ [ selection-start/end ] keep gadget-model doc-range ;
+
+: remove-selection ( editor -- )
+ [ selection-start/end ] keep gadget-model remove-doc-range ;
+
+M: editor user-input*
+ [ selection-start/end ] keep gadget-model set-doc-range t ;
+
+: editor-string ( editor -- string )
+ gadget-model doc-string ;
+
+: set-editor-string ( string editor -- )
+ gadget-model set-doc-string ;
+
+M: editor gadget-text* editor-string % ;
+
+: extend-selection ( editor -- )
+ dup request-focus dup editor-caret click-loc ;
+
+: mouse-elt ( -- element )
+ hand-click# get {
+ { 1 T{ one-char-elt } }
+ { 2 T{ one-word-elt } }
+ } at T{ one-line-elt } or ;
+
+: drag-direction? ( loc editor -- ? )
+ editor-mark* before? ;
+
+: drag-selection-caret ( loc editor element -- loc )
+ >r [ drag-direction? ] 2keep
+ gadget-model
+ r> prev/next-elt ? ;
+
+: drag-selection-mark ( loc editor element -- loc )
+ >r [ drag-direction? not ] 2keep
+ nip dup editor-mark* swap gadget-model
+ r> prev/next-elt ? ;
+
+: drag-caret&mark ( editor -- caret mark )
+ dup clicked-loc swap mouse-elt
+ [ drag-selection-caret ] 3keep
+ drag-selection-mark ;
+
+: drag-selection ( editor -- )
+ dup drag-caret&mark
+ pick editor-mark set-model
+ swap editor-caret set-model ;
+
+: editor-cut ( editor clipboard -- )
+ dupd gadget-copy remove-selection ;
+
+: delete/backspace ( elt editor quot -- )
+ over gadget-selection? [
+ drop nip remove-selection
+ ] [
+ over >r >r dup editor-caret* swap gadget-model
+ r> call r> gadget-model remove-doc-range
+ ] if ; inline
+
+: editor-delete ( editor elt -- )
+ swap [ over >r rot next-elt r> swap ] delete/backspace ;
+
+: editor-backspace ( editor elt -- )
+ swap [ over >r rot prev-elt r> ] delete/backspace ;
+
+: editor-select-prev ( editor elt -- )
+ swap [ rot prev-elt ] change-caret ;
+
+: editor-prev ( editor elt -- )
+ dupd editor-select-prev mark>caret ;
+
+: editor-select-next ( editor elt -- )
+ swap [ rot next-elt ] change-caret ;
+
+: editor-next ( editor elt -- )
+ dupd editor-select-next mark>caret ;
+
+: editor-select ( from to editor -- )
+ tuck editor-caret set-model editor-mark set-model ;
+
+: select-elt ( editor elt -- )
+ over >r
+ >r dup editor-caret* swap gadget-model r> prev/next-elt
+ r> editor-select ;
+
+: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
+
+: end-of-document ( editor -- ) T{ doc-elt } editor-next ;
+
+: position-caret ( editor -- )
+ mouse-elt dup T{ one-char-elt } =
+ [ drop dup extend-selection dup editor-mark click-loc ]
+ [ select-elt ] if ;
+
+: insert-newline ( editor -- ) "\n" swap user-input ;
+
+: delete-next-character ( editor -- )
+ T{ char-elt } editor-delete ;
+
+: delete-previous-character ( editor -- )
+ T{ char-elt } editor-backspace ;
+
+: delete-previous-word ( editor -- )
+ T{ word-elt } editor-delete ;
+
+: delete-next-word ( editor -- )
+ T{ word-elt } editor-backspace ;
+
+: delete-to-start-of-line ( editor -- )
+ T{ one-line-elt } editor-delete ;
+
+: delete-to-end-of-line ( editor -- )
+ T{ one-line-elt } editor-backspace ;
+
+editor "general" f {
+ { T{ key-down f f "DELETE" } delete-next-character }
+ { T{ key-down f { S+ } "DELETE" } delete-next-character }
+ { T{ key-down f f "BACKSPACE" } delete-previous-character }
+ { T{ key-down f { S+ } "BACKSPACE" } delete-previous-character }
+ { T{ key-down f { C+ } "DELETE" } delete-previous-word }
+ { T{ key-down f { C+ } "BACKSPACE" } delete-next-word }
+ { T{ key-down f { A+ } "DELETE" } delete-to-start-of-line }
+ { T{ key-down f { A+ } "BACKSPACE" } delete-to-end-of-line }
+} define-command-map
+
+: paste ( editor -- ) clipboard get paste-clipboard ;
+
+: paste-selection ( editor -- ) selection get paste-clipboard ;
+
+: cut ( editor -- ) clipboard get editor-cut ;
+
+editor "clipboard" f {
+ { T{ paste-action } paste }
+ { T{ button-up f f 2 } paste-selection }
+ { T{ copy-action } com-copy }
+ { T{ button-up } com-copy-selection }
+ { T{ cut-action } cut }
+} define-command-map
+
+: previous-character ( editor -- )
+ dup gadget-selection? [
+ dup selection-start/end drop
+ over set-caret mark>caret
+ ] [
+ T{ char-elt } editor-prev
+ ] if ;
+
+: next-character ( editor -- )
+ dup gadget-selection? [
+ dup selection-start/end nip
+ over set-caret mark>caret
+ ] [
+ T{ char-elt } editor-next
+ ] if ;
+
+: previous-line ( editor -- ) T{ line-elt } editor-prev ;
+
+: next-line ( editor -- ) T{ line-elt } editor-next ;
+
+: previous-word ( editor -- ) T{ word-elt } editor-prev ;
+
+: next-word ( editor -- ) T{ word-elt } editor-next ;
+
+: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
+
+: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
+
+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 f "END" } end-of-line }
+ { T{ key-down f { C+ } "HOME" } start-of-document }
+ { T{ key-down f { C+ } "END" } end-of-document }
+} define-command-map
+
+: select-all ( editor -- ) T{ doc-elt } select-elt ;
+
+: select-line ( editor -- ) T{ one-line-elt } select-elt ;
+
+: select-word ( editor -- ) T{ one-word-elt } select-elt ;
+
+: selected-word ( editor -- string )
+ dup gadget-selection?
+ [ dup select-word ] unless
+ gadget-selection ;
+
+: select-previous-character ( editor -- )
+ T{ char-elt } editor-select-prev ;
+
+: select-next-character ( editor -- )
+ T{ char-elt } editor-select-next ;
+
+: select-previous-line ( editor -- )
+ T{ line-elt } editor-select-prev ;
+
+: select-next-line ( editor -- )
+ T{ line-elt } editor-select-next ;
+
+: select-previous-word ( editor -- )
+ T{ word-elt } editor-select-prev ;
+
+: select-next-word ( editor -- )
+ T{ word-elt } editor-select-next ;
+
+: select-start-of-line ( editor -- )
+ T{ one-line-elt } editor-select-prev ;
+
+: select-end-of-line ( editor -- )
+ T{ one-line-elt } editor-select-next ;
+
+: select-start-of-document ( editor -- )
+ T{ doc-elt } editor-select-prev ;
+
+: select-end-of-document ( editor -- )
+ T{ doc-elt } editor-select-next ;
+
+editor "selection" f {
+ { T{ button-down f { S+ } } extend-selection }
+ { T{ drag } drag-selection }
+ { T{ gain-focus } focus-editor }
+ { T{ lose-focus } unfocus-editor }
+ { T{ delete-action } remove-selection }
+ { T{ select-all-action } select-all }
+ { 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 }
+ { T{ key-down f { S+ } "END" } select-end-of-line }
+ { T{ key-down f { S+ C+ } "HOME" } select-start-of-document }
+ { T{ key-down f { S+ C+ } "END" } select-end-of-document }
+} define-command-map
+
+! Multi-line editors
+TUPLE: multiline-editor < editor ;
+
+: <multiline-editor> ( -- editor )
+ multiline-editor new-editor ;
+
+multiline-editor "general" f {
+ { T{ key-down f f "RET" } insert-newline }
+ { T{ key-down f { S+ } "RET" } insert-newline }
+ { T{ key-down f f "ENTER" } insert-newline }
+} define-command-map
+
+TUPLE: source-editor < multiline-editor ;
+
+: <source-editor> ( -- editor )
+ source-editor new-editor ;
+
+! Fields wrap an editor and edit an external model
+TUPLE: field < wrapper field-model editor ;
+
+: field-theme ( gadget -- gadget )
+ gray <solid> >>boundary ; inline
+
+: <field-border> ( gadget -- border )
+ 2 <border>
+ { 1 0 } >>fill
+ field-theme ;
+
+: <field> ( model -- gadget )
+ <editor> dup <field-border> field new-wrapper
+ swap >>editor
+ swap >>field-model ;
+
+M: field graft*
+ [ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ]
+ [ dup editor>> model>> add-connection ]
+ bi ;
+
+M: field ungraft*
+ dup editor>> model>> remove-connection ;
+
+M: field model-changed
+ nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
--- /dev/null
+Editors edit a plain text document
--- /dev/null
+
+USING: kernel alien.c-types combinators sequences splitting grouping
+ opengl.gl ui.gadgets ui.render
+ math math.vectors accessors math.geometry.rect ;
+
+IN: ui.gadgets.frame-buffer
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
+ dup
+ rect-dim product "uint[4]" <c-array>
+ >>pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: new-frame-buffer ( class -- gadget )
+ new-gadget
+ [ ] >>action
+ { 100 100 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: read-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ >r
+ 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer pref-dim* pdim>> ;
+M: frame-buffer graft* graft>> call ;
+M: frame-buffer ungraft* ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: copy-row ( old new -- )
+ 2dup min-length swap >r head-slice 0 r> copy ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ group ] 2bi@
+! [ copy-row ] 2each ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ 16 * group ] 2bi@
+! [ copy-row ] 2each ;
+
+: copy-pixels ( old-pixels old-width new-pixels new-width -- )
+ [ 16 * <sliced-groups> ] 2bi@
+ [ copy-row ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer layout* ( fb -- )
+ {
+ {
+ [ dup last-dim>> f = ]
+ [
+ init-frame-buffer-pixels
+ dup
+ rect-dim >>last-dim
+ drop
+ ]
+ }
+ {
+ [ dup [ rect-dim ] [ last-dim>> ] bi = not ]
+ [
+ dup [ pixels>> ] [ last-dim>> first ] bi
+
+ rot init-frame-buffer-pixels
+ dup rect-dim >>last-dim
+
+ [ pixels>> ] [ rect-dim first ] bi
+
+ copy-pixels
+ ]
+ }
+ { [ t ] [ drop ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer draw-gadget* ( fb -- )
+
+ dup rect-dim { 0 1 } v* first2 glRasterPos2i
+
+ draw-pixels
+
+ dup action>> call
+
+ glFlush
+
+ read-pixels
+
+ drop ;
+
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.syntax help.markup ui.gadgets kernel arrays
+quotations classes.tuple ui.gadgets.grids ;
+IN: ui.gadgets.frames
+
+ARTICLE: "ui-frame-layout" "Frame layouts"
+"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames inherit from grids, grid layout words can be used to add and remove children."
+{ $subsection frame }
+"Creating empty frames:"
+{ $subsection <frame> }
+"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } ":"
+{ $subsection @center }
+{ $subsection @left }
+{ $subsection @right }
+{ $subsection @top }
+{ $subsection @bottom }
+{ $subsection @top-left }
+{ $subsection @top-right }
+{ $subsection @bottom-left }
+{ $subsection @bottom-right } ;
+
+: $ui-frame-constant ( element -- )
+ drop
+ { $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
+
+HELP: @center $ui-frame-constant ;
+HELP: @left $ui-frame-constant ;
+HELP: @right $ui-frame-constant ;
+HELP: @top $ui-frame-constant ;
+HELP: @bottom $ui-frame-constant ;
+HELP: @top-left $ui-frame-constant ;
+HELP: @top-right $ui-frame-constant ;
+HELP: @bottom-left $ui-frame-constant ;
+HELP: @bottom-right $ui-frame-constant ;
+
+HELP: frame
+{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
+$nl
+"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
+
+HELP: <frame>
+{ $values { "frame" frame } }
+{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
+
+{ grid frame } related-words
+
+ABOUT: "ui-frame-layout"
--- /dev/null
+IN: ui.gadgets.frames.tests
+USING: ui.gadgets.frames ui.gadgets tools.test ;
+
+[ ] [ <frame> layout ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays generic kernel math namespaces sequences words
+splitting grouping math.vectors ui.gadgets.grids ui.gadgets
+math.geometry.rect ;
+IN: ui.gadgets.frames
+
+! A frame arranges gadgets in a 3x3 grid, where the center
+! gadgets gets left-over space.
+TUPLE: frame < grid ;
+
+: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
+
+: @center 1 1 ;
+: @left 0 1 ;
+: @right 2 1 ;
+: @top 1 0 ;
+: @bottom 1 2 ;
+
+: @top-left 0 0 ;
+: @top-right 2 0 ;
+: @bottom-left 0 2 ;
+: @bottom-right 2 2 ;
+
+: new-frame ( class -- frame )
+ <frame-grid> swap new-grid ; inline
+
+: <frame> ( -- frame )
+ frame new-frame ;
+
+: (fill-center) ( vec n -- )
+ over first pick third v+ [v-] 1 rot set-nth ;
+
+: fill-center ( horiz vert dim -- )
+ tuck (fill-center) (fill-center) ;
+
+M: frame layout*
+ dup compute-grid
+ [ rot rect-dim fill-center ] 3keep
+ grid-layout ;
--- /dev/null
+Frames position children around a center child which fills up any remaining space
--- /dev/null
+USING: help.markup help.syntax opengl kernel strings
+ classes.tuple classes quotations models math.geometry.rect ;
+IN: ui.gadgets
+
+HELP: gadget-child
+{ $values { "gadget" gadget } { "child" gadget } }
+{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
+
+HELP: nth-gadget
+{ $values { "n" "a non-negative integer" } { "gadget" gadget } { "child" gadget } }
+{ $description "Outputs the " { $snippet "n" } "th child of the gadget." }
+{ $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ;
+
+HELP: <gadget>
+{ $values { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a new gadget." } ;
+
+HELP: relative-loc
+{ $values { "fromgadget" gadget } { "togadget" gadget } { "loc" "a pair of integers" } }
+{ $description
+ "Outputs the location of the top-left corner of " { $snippet "togadget" } " relative to the co-ordinate system of " { $snippet "fromgadget" } "."
+}
+{ $errors
+ "Throws an error if " { $snippet "togadget" } " is not contained in a child of " { $snippet "fromgadget" } "."
+} ;
+
+HELP: user-input*
+{ $values { "str" string } { "gadget" gadget } { "?" "a boolean" } }
+{ $contract "Handle free-form textual input while the gadget has keyboard focus." } ;
+
+HELP: children-on
+{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } }
+{ $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." }
+{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link gadget-children } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
+
+HELP: pick-up
+{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } }
+{ $description "Outputs the child at a point in the gadget's co-ordinate system. This word recursively descends the gadget hierarchy, and so outputs the deepest child." } ;
+
+HELP: max-dim
+{ $values { "dims" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
+{ $description "Outputs the smallest dimensions of a rectangle which can fit all the dimensions in the sequence." } ;
+
+{ pref-dims max-dim dim-sum } related-words
+
+HELP: each-child
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } }
+{ $description "Applies the quotation to each child of the gadget." } ;
+
+HELP: gadget-selection?
+{ $values { "gadget" gadget } { "?" "a boolean" } }
+{ $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ;
+
+HELP: gadget-selection
+{ $values { "gadget" gadget } { "string/f" "a " { $link string } " or " { $link f } } }
+{ $contract "Outputs the gadget's text selection, or " { $link f } " if nothing is selected." } ;
+
+HELP: relayout
+{ $values { "gadget" gadget } }
+{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $link gadget-root? } " set, so this word should be used when the gadget's dimensions have potentially changed." } ;
+
+HELP: relayout-1
+{ $values { "gadget" gadget } }
+{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout } ", this does not propagate requests up to the parent, and so this word should only be used when the gadget's internal layout or appearance has changed, but the dimensions have not." } ;
+
+{ relayout relayout-1 } related-words
+
+HELP: pref-dim*
+{ $values { "gadget" gadget } { "dim" "a pair of integers" } }
+{ $contract "Outputs the preferred dimensions of the gadget, possibly computing them from the preferred dimensions of the gadget's children." }
+{ $notes "User code should not call this word directly, instead call " { $link pref-dim } "." } ;
+
+HELP: pref-dim
+{ $values { "gadget" gadget } { "dim" "a pair of integers" } }
+{ $description "Outputs the preferred dimensions of the gadget. The value is cached between calls, and invalidated when the gadget needs to be relayout." } ;
+
+HELP: pref-dims
+{ $values { "gadgets" "a sequence of gadgets" } { "seq" "a sequence of pairs of integers" } }
+{ $description "Collects the preferred dimensions of every gadget in the sequence into a new sequence." } ;
+
+HELP: layout*
+{ $values { "gadget" gadget } }
+{ $contract "Lays out the children of the gadget according to the gadget's policy. The dimensions of the gadget are already set by the parent by the time this word is called." }
+{ $notes "User code should not call this word directly, instead call " { $link relayout } " and " { $link relayout-1 } "." } ;
+
+HELP: prefer
+{ $values { "gadget" gadget } }
+{ $contract "Resizes the gadget to assume its preferred dimensions." } ;
+
+HELP: dim-sum
+{ $values { "seq" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
+{ $description "Sums a sequence of dimensions." } ;
+
+HELP: layout
+{ $values { "gadget" gadget } }
+{ $description "Lays out the children of the gadget if the gadget needs to be relayout, and otherwise does nothing." }
+{ $notes "User code should not call this word directly, instead call " { $link relayout } " and " { $link relayout-1 } "." } ;
+
+{ pref-dim pref-dim* layout layout* } related-words
+
+HELP: graft*
+{ $values { "gadget" gadget } }
+{ $contract "Called to notify the gadget it has become visible on the screen. This should set up timers and threads, and acquire any resources used by the gadget." } ;
+
+{ graft graft* ungraft ungraft* } related-words
+
+HELP: ungraft*
+{ $values { "gadget" gadget } }
+{ $contract "Called to notify the gadget it is no longer visible on the screen. This should stop timers and threads, and release any resources used by the gadget." } ;
+
+HELP: graft
+{ $values { "gadget" gadget } }
+{ $description "Calls " { $link graft* } " on the gadget and all children." }
+{ $notes "This word should never be called directly." } ;
+
+HELP: ungraft
+{ $values { "gadget" gadget } }
+{ $description "If the gadget is grafted, calls " { $link ungraft* } " on the gadget and all children." }
+{ $notes "This word should never be called directly." } ;
+
+HELP: unparent
+{ $values { "gadget" gadget } }
+{ $description "Removes the gadget from its parent. This will relayout the parent." }
+{ $notes "This may result in " { $link ungraft* } " being called on the gadget and its children, if the gadget's parent is visible on the screen." } ;
+
+HELP: clear-gadget
+{ $values { "gadget" gadget } }
+{ $description "Removes all children from the gadget. This will relayout the gadget." }
+{ $notes "This may result in " { $link ungraft* } " being called on the children, if the gadget is visible on the screen." }
+{ $side-effects "gadget" } ;
+
+HELP: add-gadget
+{ $values { "gadget" gadget } { "parent" gadget } }
+{ $description "Adds a child gadget to a parent. If the gadget is contained in another gadget, " { $link unparent } " is called on the gadget first. The parent will be relayout." }
+{ $notes "Adding a gadget to a parent may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
+{ $side-effects "parent" } ;
+
+HELP: add-gadgets
+{ $values { "seq" "a sequence of gadgets" } { "parent" gadget } }
+{ $description "Adds a sequence of gadgets to a parent. The parent will be relayout." }
+{ $notes "This may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
+{ $side-effects "parent" } ;
+
+HELP: parents
+{ $values { "gadget" gadget } { "seq" "a sequence of gadgets" } }
+{ $description "Outputs a sequence of all parents of the gadget, with the first element being the gadget itself." } ;
+
+HELP: each-parent
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "?" "a boolean" } }
+{ $description "Applies the quotation to every parent of the gadget, starting from the gadget itself, stopping if the quotation yields " { $link f } ". Outputs " { $link t } " if the iteration completed, and outputs " { $link f } " if it was stopped prematurely." } ;
+
+HELP: find-parent
+{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "parent" gadget } }
+{ $description "Outputs the first parent of the gadget, starting from the gadget itself, for which the quotation outputs a true value, or " { $link f } " if the quotation outputs " { $link f } " for every parent." } ;
+
+HELP: screen-loc
+{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
+{ $description "Outputs the location of the gadget relative to the top-left corner of the world containing the gadget. This word does not output a useful value if the gadget is not grafted." } ;
+
+HELP: child?
+{ $values { "parent" gadget } { "child" gadget } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "child" } " is contained inside " { $snippet "parent" } "." } ;
+
+HELP: focusable-child*
+{ $values { "gadget" gadget } { "child/t" "a " { $link gadget } " or " { $link t } } }
+{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus, or " { $link t } " if the gadget itself should receive focus." }
+{ $examples "For example, if your gadget consists of an editor together with an output area whose contents react to changes in editor contents, then the " { $link focusable-child* } " method for your gadget class should return the editor, so that when the gadget is displayed in a window or passed to " { $link request-focus } ", the editor receives keyboard focus automatically." } ;
+
+HELP: focusable-child
+{ $values { "gadget" gadget } { "child" gadget } }
+{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
+
+{ control-value set-control-value gadget-model } related-words
+
+HELP: control-value
+{ $values { "control" gadget } { "value" object } }
+{ $description "Outputs the value of the control's model." } ;
+
+HELP: set-control-value
+{ $values { "value" object } { "control" gadget } }
+{ $description "Sets the value of the control's model." } ;
+
+ARTICLE: "ui-control-impl" "Implementing controls"
+"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance."
+$nl
+"Some utility words useful in control implementations:"
+{ $subsection gadget-model }
+{ $subsection control-value }
+{ $subsection set-control-value }
+{ $see-also "models" } ;
--- /dev/null
+IN: ui.gadgets.tests
+USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
+tools.test namespaces models kernel dlists dequeues math sets
+math.parser ui sequences hashtables assocs io arrays prettyprint
+io.streams.string math.geometry.rect ;
+
+[ { 300 300 } ]
+[
+ ! c contains b contains a
+ <gadget> "a" set
+ <gadget> "b" set
+ "a" get "b" get swap add-gadget drop
+ <gadget> "c" set
+ "b" get "c" get swap add-gadget drop
+
+ ! position a and b
+ { 100 200 } "a" get set-rect-loc
+ { 200 100 } "b" get set-rect-loc
+
+ ! give c a loc, it doesn't matter
+ { -1000 23 } "c" get set-rect-loc
+
+ ! what is the location of a inside c?
+ "a" get "c" get relative-loc
+] unit-test
+
+<gadget> "g1" set
+{ 10 10 } "g1" get set-rect-loc
+{ 30 30 } "g1" get set-rect-dim
+<gadget> "g2" set
+{ 20 20 } "g2" get set-rect-loc
+{ 50 500 } "g2" get set-rect-dim
+<gadget> "g3" set
+{ 100 200 } "g3" get set-rect-dim
+
+"g1" get "g2" get swap add-gadget drop
+"g2" get "g3" get swap add-gadget drop
+
+[ { 30 30 } ] [ "g1" get screen-loc ] unit-test
+[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
+[ { 30 30 } ] [ "g1" get screen-rect rect-dim ] unit-test
+[ { 20 20 } ] [ "g2" get screen-loc ] unit-test
+[ { 20 20 } ] [ "g2" get screen-rect rect-loc ] unit-test
+[ { 50 180 } ] [ "g2" get screen-rect rect-dim ] unit-test
+[ { 0 0 } ] [ "g3" get screen-loc ] unit-test
+[ { 0 0 } ] [ "g3" get screen-rect rect-loc ] unit-test
+[ { 100 200 } ] [ "g3" get screen-rect rect-dim ] unit-test
+
+<gadget> "g1" set
+{ 300 300 } "g1" get set-rect-dim
+<gadget> "g2" set
+"g2" get "g1" get swap add-gadget drop
+{ 20 20 } "g2" get set-rect-loc
+{ 20 20 } "g2" get set-rect-dim
+<gadget> "g3" set
+"g3" get "g1" get swap add-gadget drop
+{ 100 100 } "g3" get set-rect-loc
+{ 20 20 } "g3" get set-rect-dim
+
+[ t ] [ { 30 30 } "g2" get inside? ] unit-test
+
+[ t ] [ { 30 30 } "g1" get (pick-up) "g2" get eq? ] unit-test
+
+[ t ] [ { 30 30 } "g1" get pick-up "g2" get eq? ] unit-test
+
+[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
+
+<gadget> "g4" set
+"g4" get "g2" get swap add-gadget drop
+{ 5 5 } "g4" get set-rect-loc
+{ 1 1 } "g4" get set-rect-dim
+
+[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
+
+TUPLE: mock-gadget < gadget graft-called ungraft-called ;
+
+: <mock-gadget> ( -- gadget )
+ mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ;
+
+M: mock-gadget graft*
+ dup mock-gadget-graft-called 1+
+ swap set-mock-gadget-graft-called ;
+
+M: mock-gadget ungraft*
+ dup mock-gadget-ungraft-called 1+
+ swap set-mock-gadget-ungraft-called ;
+
+! We can't print to output-stream here because that might be a pane
+! stream, and our graft-queue rebinding here would be captured
+! by code adding children to the pane...
+[
+ <dlist> \ graft-queue [
+ [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
+ [ t ] [ graft-queue dequeue-empty? ] unit-test
+ ] with-variable
+
+ <dlist> \ graft-queue [
+ [ t ] [ graft-queue dequeue-empty? ] unit-test
+
+ <mock-gadget> "g" set
+ [ ] [ "g" get queue-graft ] unit-test
+ [ f ] [ graft-queue dequeue-empty? ] unit-test
+ [ { f t } ] [ "g" get gadget-graft-state ] unit-test
+ [ ] [ "g" get graft-later ] unit-test
+ [ { f t } ] [ "g" get gadget-graft-state ] unit-test
+ [ ] [ "g" get ungraft-later ] unit-test
+ [ { f f } ] [ "g" get gadget-graft-state ] unit-test
+ [ t ] [ graft-queue dequeue-empty? ] unit-test
+ [ ] [ "g" get ungraft-later ] unit-test
+ [ ] [ "g" get graft-later ] unit-test
+ [ ] [ notify-queued ] unit-test
+ [ { t t } ] [ "g" get gadget-graft-state ] unit-test
+ [ t ] [ graft-queue dequeue-empty? ] unit-test
+ [ ] [ "g" get graft-later ] unit-test
+ [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
+ [ ] [ "g" get ungraft-later ] unit-test
+ [ { t f } ] [ "g" get gadget-graft-state ] unit-test
+ [ ] [ notify-queued ] unit-test
+ [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
+ [ { f f } ] [ "g" get gadget-graft-state ] unit-test
+ ] with-variable
+
+ : add-some-children
+ 3 [
+ <mock-gadget> over <model> over set-gadget-model
+ dup "g" get swap add-gadget drop
+ swap 1+ number>string set
+ ] each ;
+
+ : status-flags
+ { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
+
+ : notify-combo ( ? ? -- )
+ nl "===== Combo: " write 2dup 2array . nl
+ <dlist> \ graft-queue [
+ <mock-gadget> "g" set
+ [ ] [ add-some-children ] unit-test
+ [ V{ { f f } } ] [ status-flags ] unit-test
+ [ ] [ "g" get graft ] unit-test
+ [ V{ { f t } } ] [ status-flags ] unit-test
+ dup [ [ ] [ notify-queued ] unit-test ] when
+ [ ] [ "g" get clear-gadget ] unit-test
+ [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
+ [ [ ] [ notify-queued ] unit-test ] when
+ [ ] [ add-some-children ] unit-test
+ [ { f t } ] [ "1" get gadget-graft-state ] unit-test
+ [ { f t } ] [ "2" get gadget-graft-state ] unit-test
+ [ { f t } ] [ "3" get gadget-graft-state ] unit-test
+ [ ] [ graft-queue [ "x" print notify ] slurp-dequeue ] unit-test
+ [ ] [ notify-queued ] unit-test
+ [ V{ { t t } } ] [ status-flags ] unit-test
+ ] with-variable ;
+
+ { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
+] with-string-writer print
+
+\ <gadget> must-infer
+\ unparent must-infer
+\ add-gadget must-infer
+\ add-gadgets must-infer
+\ clear-gadget must-infer
+
+\ relayout must-infer
+\ relayout-1 must-infer
+\ pref-dim must-infer
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays hashtables kernel models math namespaces
+ sequences quotations math.vectors combinators sorting
+ binary-search vectors dlists dequeues models threads
+ concurrency.flags math.order math.geometry.rect ;
+
+IN: ui.gadgets
+
+SYMBOL: ui-notify-flag
+
+: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
+
+TUPLE: gadget < rect
+ pref-dim parent children orientation focus
+ visible? root? clipped? layout-state graft-state graft-node
+ interior boundary
+ model ;
+
+M: gadget equal? 2drop f ;
+
+M: gadget hashcode* drop gadget hashcode* ;
+
+M: gadget model-changed 2drop ;
+
+: gadget-child ( gadget -- child ) children>> first ;
+
+: nth-gadget ( n gadget -- child ) children>> nth ;
+
+: init-gadget ( gadget -- gadget )
+ init-rect
+ { 0 1 } >>orientation
+ t >>visible?
+ { f f } >>graft-state ; inline
+
+: new-gadget ( class -- gadget ) new init-gadget ; inline
+
+: <gadget> ( -- gadget )
+ gadget new-gadget ;
+
+: activate-control ( gadget -- )
+ dup model>> dup [
+ 2dup add-connection
+ swap model-changed
+ ] [
+ 2drop
+ ] if ;
+
+: deactivate-control ( gadget -- )
+ dup model>> dup [ 2dup remove-connection ] when 2drop ;
+
+: control-value ( control -- value )
+ model>> model-value ;
+
+: set-control-value ( value control -- )
+ model>> set-model ;
+
+: relative-loc ( fromgadget togadget -- loc )
+ 2dup eq? [
+ 2drop { 0 0 }
+ ] [
+ over rect-loc >r
+ >r parent>> r> relative-loc
+ r> v+
+ ] if ;
+
+GENERIC: user-input* ( str gadget -- ? )
+
+M: gadget user-input* 2drop t ;
+
+GENERIC: children-on ( rect/point gadget -- seq )
+
+M: gadget children-on nip children>> ;
+
+: ((fast-children-on)) ( gadget dim axis -- <=> )
+ [ swap loc>> v- ] dip v. 0 <=> ;
+
+: (fast-children-on) ( dim axis children -- i )
+ -rot [ ((fast-children-on)) ] 2curry search drop ;
+
+: fast-children-on ( rect axis children -- from to )
+ [ [ rect-loc ] 2dip (fast-children-on) 0 or ]
+ [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
+ 3bi ;
+
+: inside? ( bounds gadget -- ? )
+ dup visible?>> [ intersects? ] [ 2drop f ] if ;
+
+: (pick-up) ( point gadget -- gadget )
+ dupd children-on [ inside? ] with find-last nip ;
+
+: pick-up ( point gadget -- child/f )
+ 2dup (pick-up) dup
+ [ nip [ rect-loc v- ] keep pick-up ] [ rot 2drop ] if ;
+
+: max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
+
+: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
+
+: orient ( gadget seq1 seq2 -- seq )
+ >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
+
+: each-child ( gadget quot -- )
+ >r children>> r> each ; inline
+
+! Selection protocol
+GENERIC: gadget-selection? ( gadget -- ? )
+
+M: gadget gadget-selection? drop f ;
+
+GENERIC: gadget-selection ( gadget -- string/f )
+
+M: gadget gadget-selection drop f ;
+
+! Text protocol
+GENERIC: gadget-text* ( gadget -- )
+
+GENERIC: gadget-text-separator ( gadget -- str )
+
+M: gadget gadget-text-separator
+ orientation>> { 0 1 } = "\n" "" ? ;
+
+: gadget-seq-text ( seq gadget -- )
+ gadget-text-separator swap
+ [ dup % ] [ gadget-text* ] interleave drop ;
+
+M: gadget gadget-text*
+ dup children>> swap gadget-seq-text ;
+
+M: array gadget-text*
+ [ gadget-text* ] each ;
+
+: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
+
+: invalidate ( gadget -- )
+ \ invalidate swap (>>layout-state) ;
+
+: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
+
+: layout-queue ( -- queue ) \ layout-queue get ;
+
+: layout-later ( gadget -- )
+ #! When unit testing gadgets without the UI running, the
+ #! invalid queue is not initialized and we simply ignore
+ #! invalidation requests.
+ layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
+
+DEFER: relayout
+
+: invalidate* ( gadget -- )
+ \ invalidate* over (>>layout-state)
+ dup forget-pref-dim
+ dup gadget-root?
+ [ layout-later ] [ parent>> [ relayout ] when* ] if ;
+
+: relayout ( gadget -- )
+ dup layout-state>> \ invalidate* eq?
+ [ drop ] [ invalidate* ] if ;
+
+: relayout-1 ( gadget -- )
+ dup layout-state>>
+ [ drop ] [ dup invalidate layout-later ] if ;
+
+: show-gadget ( gadget -- ) t swap (>>visible?) ;
+
+: hide-gadget ( gadget -- ) f swap (>>visible?) ;
+
+DEFER: in-layout?
+
+: do-invalidate ( gadget -- gadget )
+ in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
+
+M: gadget (>>dim) ( dim gadget -- )
+ 2dup dim>> =
+ [ 2drop ]
+ [ tuck call-next-method do-invalidate drop ]
+ if ;
+
+GENERIC: pref-dim* ( gadget -- dim )
+
+: ?set-gadget-pref-dim ( dim gadget -- )
+ dup layout-state>>
+ [ 2drop ] [ (>>pref-dim) ] if ;
+
+: pref-dim ( gadget -- dim )
+ dup pref-dim>> [ ] [
+ [ pref-dim* dup ] keep ?set-gadget-pref-dim
+ ] ?if ;
+
+: pref-dims ( gadgets -- seq ) [ pref-dim ] map ;
+
+M: gadget pref-dim* rect-dim ;
+
+GENERIC: layout* ( gadget -- )
+
+M: gadget layout* drop ;
+
+: prefer ( gadget -- ) dup pref-dim swap (>>dim) ;
+
+: validate ( gadget -- ) f swap (>>layout-state) ;
+
+: layout ( gadget -- )
+ dup layout-state>> [
+ dup validate
+ dup layout*
+ dup [ layout ] each-child
+ ] when drop ;
+
+: graft-queue ( -- dlist ) \ graft-queue get ;
+
+: unqueue-graft ( gadget -- )
+ [ graft-node>> graft-queue delete-node ]
+ [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
+
+: (queue-graft) ( gadget flags -- )
+ >>graft-state
+ dup graft-queue push-front* >>graft-node drop
+ notify-ui-thread ;
+
+: queue-graft ( gadget -- )
+ { f t } (queue-graft) ;
+
+: queue-ungraft ( gadget -- )
+ { t f } (queue-graft) ;
+
+: graft-later ( gadget -- )
+ dup graft-state>> {
+ { { f t } [ drop ] }
+ { { t t } [ drop ] }
+ { { t f } [ unqueue-graft ] }
+ { { f f } [ queue-graft ] }
+ } case ;
+
+: ungraft-later ( gadget -- )
+ dup graft-state>> {
+ { { f f } [ drop ] }
+ { { t f } [ drop ] }
+ { { f t } [ unqueue-graft ] }
+ { { t t } [ queue-ungraft ] }
+ } case ;
+
+GENERIC: graft* ( gadget -- )
+
+M: gadget graft* drop ;
+
+: graft ( gadget -- )
+ dup graft-later [ graft ] each-child ;
+
+GENERIC: ungraft* ( gadget -- )
+
+M: gadget ungraft* drop ;
+
+: ungraft ( gadget -- )
+ dup [ ungraft ] each-child ungraft-later ;
+
+: (unparent) ( gadget -- )
+ dup ungraft
+ dup forget-pref-dim
+ f swap (>>parent) ;
+
+: unfocus-gadget ( child gadget -- )
+ tuck focus>> eq?
+ [ f swap (>>focus) ] [ drop ] if ;
+
+SYMBOL: in-layout?
+
+: not-in-layout ( -- )
+ in-layout? get
+ [ "Cannot add/remove gadgets in layout*" throw ] when ;
+
+: unparent ( gadget -- )
+ not-in-layout
+ [
+ dup parent>> dup [
+ over (unparent)
+ [ unfocus-gadget ] 2keep
+ [ children>> delete ] keep
+ relayout
+ ] [
+ 2drop
+ ] if
+ ] when* ;
+
+: (clear-gadget) ( gadget -- )
+ dup [ (unparent) ] each-child
+ f over (>>focus)
+ f swap (>>children) ;
+
+: clear-gadget ( gadget -- )
+ not-in-layout
+ dup (clear-gadget) relayout ;
+
+: ((add-gadget)) ( parent child -- parent )
+ over children>> ?push >>children ;
+
+: (add-gadget) ( parent child -- parent )
+ dup unparent
+ over >>parent
+ tuck ((add-gadget))
+ tuck graft-state>> second
+ [ graft ]
+ [ drop ]
+ if ;
+
+: add-gadget ( parent child -- parent )
+ not-in-layout
+ (add-gadget)
+ dup relayout ;
+
+: add-gadgets ( parent children -- parent )
+ not-in-layout
+ [ (add-gadget) ] each
+ dup relayout ;
+
+: parents ( gadget -- seq )
+ [ parent>> ] follow ;
+
+: each-parent ( gadget quot -- ? )
+ >r parents r> all? ; inline
+
+: find-parent ( gadget quot -- parent )
+ >r parents r> find nip ; inline
+
+: screen-loc ( gadget -- loc )
+ parents { 0 0 } [ rect-loc v+ ] reduce ;
+
+: (screen-rect) ( gadget -- loc ext )
+ dup parent>> [
+ >r rect-extent r> (screen-rect)
+ >r tuck v+ r> vmin >r v+ r>
+ ] [
+ rect-extent
+ ] if* ;
+
+: screen-rect ( gadget -- rect )
+ (screen-rect) <extent-rect> ;
+
+: child? ( parent child -- ? )
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ dup not ] [ 2drop f ] }
+ [ parent>> child? ]
+ } cond ;
+
+GENERIC: focusable-child* ( gadget -- child/t )
+
+M: gadget focusable-child* drop t ;
+
+: focusable-child ( gadget -- child )
+ dup focusable-child*
+ dup t eq? [ drop ] [ nip focusable-child ] if ;
+
+GENERIC: request-focus-on ( child gadget -- )
+
+M: gadget request-focus-on parent>> request-focus-on ;
+
+M: f request-focus-on 2drop ;
+
+: request-focus ( gadget -- )
+ [ focusable-child ] keep request-focus-on ;
+
+: focus-path ( world -- seq )
+ [ focus>> ] follow ;
+
+! Deprecated
+
+: construct-gadget ( class -- tuple )
+ >r <gadget> { set-delegate } r> construct ; inline
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax ui.gadgets.grids
+ui.render ;
+IN: ui.gadgets.grid-lines
+
+HELP: grid-lines
+{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ;
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces opengl opengl.gl sequences
+math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
+IN: ui.gadgets.grid-lines
+
+TUPLE: grid-lines color ;
+
+C: <grid-lines> grid-lines
+
+SYMBOL: grid-dim
+
+: half-gap grid get grid-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 ;
+
+: draw-grid-lines ( gaps orientation -- )
+ grid get rot grid-positions grid get rect-dim suffix [
+ grid-line-from/to gl-line
+ ] with each ;
+
+M: grid-lines draw-boundary
+ origin get [
+ -0.5 -0.5 0.0 glTranslated
+ grid-lines-color set-color [
+ dup grid set
+ dup rect-dim half-gap v- grid-dim set
+ compute-grid
+ { 0 1 } draw-grid-lines
+ { 1 0 } draw-grid-lines
+ ] with-scope
+ ] with-translation ;
--- /dev/null
+Grid lines visibly separate children of grids and frames
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax arrays ;
+IN: ui.gadgets.grids
+
+ARTICLE: "ui-grid-layout" "Grid layouts"
+"Grid gadgets layout their children in a rectangular grid."
+{ $subsection grid }
+"Creating grids from a fixed set of gadgets:"
+{ $subsection <grid> }
+"Managing chidren:"
+{ $subsection grid-add }
+{ $subsection grid-remove }
+{ $subsection grid-child } ;
+
+HELP: grid
+{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
+$nl
+"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
+$nl
+"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
+$nl
+"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
+$nl
+"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
+
+HELP: <grid>
+{ $values { "children" "a sequence of sequences of gadgets" } { "grid" "a new " { $link grid } } }
+{ $description "Creates a new " { $link grid } " gadget with the given children." } ;
+
+HELP: grid-child
+{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } { "gadget" gadget } }
+{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
+{ $errors "Throws an error if the indices are out of bounds." } ;
+
+HELP: grid-add
+{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
+{ $description "Adds a child gadget at the specified location." }
+{ $side-effects "grid" } ;
+
+HELP: grid-remove
+{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
+{ $description "Removes a child gadget from the specified location." }
+{ $side-effects "grid" } ;
+
+ABOUT: "ui-grid-layout"
--- /dev/null
+USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
+namespaces math.geometry.rect ;
+IN: ui.gadgets.grids.tests
+
+[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
+
+: 100x100 <gadget> { 100 100 } over set-rect-dim ;
+
+[ { 100 100 } ] [
+ 100x100
+ 1array 1array <grid> pref-dim
+] unit-test
+
+[ { 100 100 } ] [
+ 100x100
+ 1array 1array <grid> pref-dim
+] unit-test
+
+[ { 200 100 } ] [
+ 100x100
+ 100x100
+ 2array 1array <grid> pref-dim
+] unit-test
+
+[ { 100 200 } ] [
+ 100x100
+ 100x100
+ [ 1array ] bi@ 2array <grid> pref-dim
+] unit-test
+
+[ ] [
+ 100x100
+ 100x100
+ [ 1array ] bi@ 2array <grid> layout
+] unit-test
+
+[ { 230 120 } { 100 100 } { 100 100 } ] [
+ 100x100 dup "a" set
+ 100x100 dup "b" set
+ 2array 1array <grid>
+ { 10 10 } over set-grid-gap
+ dup prefer
+ dup layout
+ rect-dim
+ "a" get rect-dim
+ "b" get rect-dim
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math namespaces sequences words io
+io.streams.string math.vectors ui.gadgets columns accessors
+math.geometry.rect ;
+IN: ui.gadgets.grids
+
+TUPLE: grid < gadget
+grid
+{ gap initial: { 0 0 } }
+{ fill? initial: t } ;
+
+: new-grid ( children class -- grid )
+ new-gadget
+ [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
+ inline
+
+: <grid> ( children -- grid )
+ grid new-grid ;
+
+: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
+
+: grid-add ( grid child i j -- grid )
+ >r >r dupd swap r> r>
+ >r >r 2dup swap add-gadget drop r> r>
+ 3dup grid-child unparent rot grid>> nth set-nth ;
+
+: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
+
+: pref-dim-grid ( grid -- dims )
+ grid>> [ [ pref-dim ] map ] map ;
+
+: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
+
+: compute-grid ( grid -- horiz vert )
+ pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
+
+: (pair-up) ( horiz vert -- dim )
+ >r first r> second 2array ;
+
+: pair-up ( horiz vert -- dims )
+ [ [ (pair-up) ] curry map ] with map ;
+
+: add-gaps ( gap seq -- newseq )
+ [ v+ ] with map ;
+
+: gap-sum ( gap seq -- newseq )
+ dupd add-gaps dim-sum v+ ;
+
+M: grid pref-dim*
+ dup grid-gap swap compute-grid >r over r>
+ gap-sum >r gap-sum r> (pair-up) ;
+
+: do-grid ( dims grid quot -- )
+ -rot grid>>
+ [ [ pick call ] 2each ] 2each
+ drop ; inline
+
+: grid-positions ( grid dims -- locs )
+ >r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ;
+
+: position-grid ( grid horiz vert -- )
+ pick >r
+ >r over r> grid-positions >r grid-positions r>
+ pair-up r> [ set-rect-loc ] do-grid ;
+
+: resize-grid ( grid horiz vert -- )
+ pick grid-fill? [
+ pair-up swap [ (>>dim) ] do-grid
+ ] [
+ 2drop grid>> [ [ prefer ] each ] each
+ ] if ;
+
+: grid-layout ( grid horiz vert -- )
+ [ position-grid ] 3keep resize-grid ;
+
+M: grid layout* dup compute-grid grid-layout ;
+
+M: grid children-on ( rect gadget -- seq )
+ dup gadget-children empty? [
+ 2drop f
+ ] [
+ { 0 1 } swap grid>>
+ [ 0 <column> fast-children-on ] keep
+ <slice> concat
+ ] if ;
+
+M: grid gadget-text*
+ grid>>
+ [ [ gadget-text ] map ] map format-table
+ [ CHAR: \n , ] [ % ] interleave ;
--- /dev/null
+Grids arrange children in a variable-size grid
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
+
+IN: ui.gadgets.handler
+
+TUPLE: handler < wrapper table ;
+
+: <handler> ( child -- handler ) handler new-wrapper ;
+
+M: handler handle-gesture* ( gadget gesture delegate -- ? )
+ table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax ui.gadgets.packs ;
+IN: ui.gadgets.incremental
+
+HELP: incremental
+{ $class-description "Incremental layout gadgets inherit from " { $link pack } " and implement an optimization where the relayout operation after adding a child to be done in constant time."
+$nl
+"Incremental layout gadgets are created by calling " { $link <incremental> } "."
+$nl
+"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
+$nl
+"Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for " { $link pack-align } ", " { $link pack-fill } ", and " { $link pack-gap } "." } ;
+
+HELP: <incremental>
+{ $values { "pack" pack } { "incremental" "a new instance of " { $link incremental } } }
+{ $description "Creates a new incremental layout gadget delegating to " { $snippet "pack" } "." } ;
+
+{ <incremental> add-incremental clear-incremental } related-words
+
+HELP: add-incremental
+{ $values { "gadget" gadget } { "incremental" incremental } }
+{ $description "Adds the gadget to the incremental layout and performs relayout immediately in constant time." }
+{ $side-effects "incremental" } ;
+
+HELP: clear-incremental
+{ $values { "incremental" incremental } }
+{ $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." }
+{ $side-effects "incremental" } ;
+
+ARTICLE: "ui-incremental-layout" "Incremental layouts"
+"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
+$nl
+"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
+$nl
+"Incremental layout is used by " { $link "ui.gadgets.panes" } " to ensure that new lines of output does not take longer to display when the pane already has previous output."
+$nl
+"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
+{ $subsection incremental }
+{ $subsection <incremental> }
+"Children are added and removed with a special set of words which perform necessary relayout immediately:"
+{ $subsection add-incremental }
+{ $subsection clear-incremental }
+"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
+
+ABOUT: "ui-incremental-layout"
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io kernel math namespaces math.vectors ui.gadgets
+ui.gadgets.packs accessors math.geometry.rect ;
+IN: ui.gadgets.incremental
+
+! Incremental layout allows adding lines to panes to be O(1).
+! Note that incremental packs are distinct from ordinary packs
+! defined in layouts.factor, since you don't want all packs to
+! be incremental. In particular, incremental packs do not
+! support non-default values for pack-align, pack-fill and
+! pack-gap.
+
+! The cursor is the current size of the incremental pack.
+! New gadgets are added at
+! incremental-cursor gadget-orientation v*
+
+TUPLE: incremental < pack cursor ;
+
+: <incremental> ( -- incremental )
+ incremental new-gadget
+ { 0 1 } >>orientation
+ { 0 0 } >>cursor ;
+
+M: incremental pref-dim*
+ dup gadget-layout-state [
+ dup call-next-method over set-incremental-cursor
+ ] when incremental-cursor ;
+
+: next-cursor ( gadget incremental -- cursor )
+ [
+ swap rect-dim swap incremental-cursor
+ 2dup v+ >r vmax r>
+ ] keep gadget-orientation set-axis ;
+
+: update-cursor ( gadget incremental -- )
+ [ next-cursor ] keep set-incremental-cursor ;
+
+: incremental-loc ( gadget incremental -- )
+ dup incremental-cursor swap gadget-orientation v*
+ swap set-rect-loc ;
+
+: prefer-incremental ( gadget -- )
+ dup forget-pref-dim dup pref-dim swap set-rect-dim ;
+
+: add-incremental ( gadget incremental -- )
+ not-in-layout
+ 2dup swap (add-gadget) drop
+ over prefer-incremental
+ over layout-later
+ 2dup incremental-loc
+ tuck update-cursor
+ dup prefer-incremental
+ gadget-parent [ invalidate* ] when* ;
+
+: clear-incremental ( incremental -- )
+ not-in-layout
+ dup (clear-gadget)
+ dup forget-pref-dim
+ { 0 0 } over set-incremental-cursor
+ gadget-parent [ relayout ] when* ;
--- /dev/null
+Children can be added to incremental layouts in constant time
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax strings models
+ui.gadgets.panes ;
+IN: ui.gadgets.labelled
+
+HELP: labelled-gadget
+{ $class-description "A labelled gadget can be created by calling " { $link <labelled-gadget> } "." } ;
+
+HELP: <labelled-gadget>
+{ $values { "gadget" gadget } { "title" string } { "newgadget" "a new " { $link <labelled-gadget> } } }
+{ $description "Creates a new " { $link labelled-gadget } " display " { $snippet "gadget" } " with " { $snippet "title" } " on top." } ;
+
+HELP: closable-gadget
+{ $class-description "A closable gadget displays a title bar with a close box on top of another gadget. Clicking the close box invokes a quotation. Closable gadgets are created by calling " { $link <closable-gadget> } "." } ;
+
+HELP: <closable-gadget>
+{ $values { "gadget" gadget } { "title" string } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
+{ $description "Creates a new " { $link closable-gadget } ". Clicking the close box calls " { $snippet "quot" } "." }
+{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;
+
+HELP: <labelled-pane>
+{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
+
+{ <labelled-pane> <pane-control> } related-words
+
+ARTICLE: "ui.gadgets.labelled" "Labelled gadgets"
+"It is possible to create a labelled border around a child gadget:"
+{ $subsection labelled-gadget }
+{ $subsection <labelled-gadget> }
+"Or a labelled border with a close box:"
+{ $subsection closable-gadget }
+{ $subsection <closable-gadget> } ;
+
+ABOUT: "ui.gadgets.labelled"
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays ui.gadgets.buttons ui.gadgets.borders
+ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
+ui.gadgets.grids io kernel math models namespaces prettyprint
+sequences sequences words classes.tuple ui.gadgets ui.render
+colors accessors ;
+IN: ui.gadgets.labelled
+
+TUPLE: labelled-gadget < track content ;
+
+: <labelled-gadget> ( gadget title -- newgadget )
+ { 0 1 } labelled-gadget new-track
+ swap <label> reverse-video-theme f track-add
+ swap >>content
+ dup content>> 1 track-add ;
+
+M: labelled-gadget focusable-child* labelled-gadget-content ;
+
+: <labelled-scroller> ( gadget title -- gadget )
+ >r <scroller> r> <labelled-gadget> ;
+
+: <labelled-pane> ( model quot scrolls? title -- gadget )
+ >r >r <pane-control> r> over set-pane-scrolls? r>
+ <labelled-scroller> ;
+
+: <close-box> ( quot -- button/f )
+ gray close-box <polygon-gadget> swap <bevel-button> ;
+
+: title-theme ( gadget -- )
+ { 1 0 } over set-gadget-orientation
+ T{ gradient f {
+ T{ rgba f 0.65 0.65 1.0 1.0 }
+ T{ rgba f 0.65 0.45 1.0 1.0 }
+ } } swap set-gadget-interior ;
+
+: <title-label> ( text -- label ) <label> dup title-theme ;
+
+: <title-bar> ( title quot -- gadget )
+ <frame>
+ swap dup [ <close-box> @left grid-add ] [ drop ] if
+ swap <title-label> @center grid-add ;
+
+TUPLE: closable-gadget < frame content ;
+
+: find-closable-gadget ( parent -- child )
+ [ [ closable-gadget? ] is? ] find-parent ;
+
+: <closable-gadget> ( gadget title quot -- gadget )
+ closable-gadget new-frame
+ -rot <title-bar> @top grid-add
+ swap >>content
+ dup content>> @center grid-add ;
+
+M: closable-gadget focusable-child* closable-gadget-content ;
--- /dev/null
+Labelled gadgets display a border with a text label surrounding a child
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax strings ui.gadgets models ;
+IN: ui.gadgets.labels
+
+HELP: label
+{ $class-description "A label displays a piece of text, either a single line string or an array of line strings. Labels are created by calling " { $link <label> } "." } ;
+
+HELP: <label>
+{ $values { "string" string } { "label" "a new " { $link label } } }
+{ $description "Creates a new " { $link label } " gadget. The string is permitted to contain line breaks." } ;
+
+HELP: label-string
+{ $values { "label" label } { "string" string } }
+{ $description "Outputs the string currently displayed by the label." } ;
+
+HELP: set-label-string
+{ $values { "label" label } { "string" string } }
+{ $description "Sets the string currently displayed by the label. The string is permitted to contain line breaks. After calling this word, you must also call " { $link relayout } " on the label." } ;
+
+HELP: <label-control>
+{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a control which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;
+
+{ label-string set-label-string } related-words
+{ <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."
+{ $subsection label }
+{ $subsection <label> }
+{ $subsection <label-control> }
+{ $subsection label-string }
+{ $subsection set-label-string }
+"Label specifiers are used by buttons, checkboxes and radio buttons:"
+{ $subsection >label } ;
+
+ABOUT: "ui.gadgets.labels"
+
+HELP: >label
+{ $values { "obj" "a label specifier" } { "gadget" "a new " { $link gadget } } }
+{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ;
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays hashtables io kernel math namespaces
+opengl sequences strings splitting
+ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
+models ;
+IN: ui.gadgets.labels
+
+! A label gadget draws a string.
+TUPLE: label < gadget text font color ;
+
+: label-string ( label -- string )
+ text>> dup string? [ "\n" join ] unless ; inline
+
+: set-label-string ( string label -- )
+ CHAR: \n pick memq? [
+ >r string-lines r> set-label-text
+ ] [
+ set-label-text
+ ] if ; inline
+
+: label-theme ( gadget -- gadget )
+ sans-serif-font >>font
+ black >>color ; inline
+
+: new-label ( string class -- label )
+ new-gadget
+ [ set-label-string ] keep
+ label-theme ; inline
+
+: <label> ( string -- label )
+ label new-label ;
+
+M: label pref-dim*
+ [ font>> open-font ] [ text>> ] bi text-dim ;
+
+M: label draw-gadget*
+ [ color>> set-color ]
+ [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
+
+M: label gadget-text* label-string % ;
+
+TUPLE: label-control < label ;
+
+M: label-control model-changed
+ swap model-value over set-label-string relayout ;
+
+: <label-control> ( model -- gadget )
+ "" label-control new-label
+ swap >>model ;
+
+: text-theme ( gadget -- gadget )
+ black >>color
+ monospace-font >>font ;
+
+: reverse-video-theme ( label -- label )
+ white >>color
+ black solid-interior ;
+
+GENERIC: >label ( obj -- gadget )
+M: string >label <label> ;
+M: array >label <label> ;
+M: object >label ;
+M: f >label drop <gadget> ;
+
+: label-on-left ( gadget label -- button )
+ { 1 0 } <track>
+ swap >label f track-add
+ swap 1 track-add ;
+
+: label-on-right ( label gadget -- button )
+ { 1 0 } <track>
+ swap f track-add
+ swap >label 1 track-add ;
--- /dev/null
+Label gadgets display one or more lines of text with a single font and color
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: ui.backend ui.gadgets.worlds ;
+
+IN: ui.gadgets.lib
+
+: find-gl-context ( gadget -- ) find-world world-handle select-gl-context ;
--- /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" "a quotation with stack effect " { $snippet "( list -- )" } } { "presenter" "a quotation with stack effect " { $snippet "( 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 list-index over calc-bounded-index
+ swap set-list-index ;
+
+: list-presentation-hook ( list -- quot )
+ hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
+
+: <list-presentation> ( hook elt presenter -- gadget )
+ keep >r >label text-theme r>
+ <presentation>
+ swap >>hook ; inline
+
+: <list-items> ( list -- seq )
+ [ list-presentation-hook ]
+ [ presenter>> ]
+ [ control-value ]
+ tri [
+ >r 2dup r> swap <list-presentation>
+ ] map 2nip ;
+
+M: list model-changed
+ nip
+ dup clear-gadget
+ dup <list-items> over swap add-gadgets drop
+ bound-index ;
+
+: selected-rect ( list -- rect )
+ dup list-index swap gadget-children ?nth ;
+
+M: list draw-gadget*
+ origin get [
+ dup list-color set-color
+ selected-rect [ rect-extent gl-fill-rect ] when*
+ ] with-translation ;
+
+M: list focusable-child* drop t ;
+
+: list-value ( list -- object )
+ dup list-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
+ [ set-list-index ] keep
+ [ relayout-1 ] keep
+ scroll>selected
+ ] if ;
+
+: select-previous ( list -- )
+ dup list-index 1- swap select-index ;
+
+: select-next ( list -- )
+ dup list-index 1+ swap select-index ;
+
+: invoke-value-action ( list -- )
+ dup list-empty? [
+ dup list-hook call
+ ] [
+ dup list-index swap nth-gadget invoke-secondary
+ ] if ;
+
+: select-gadget ( gadget list -- )
+ swap over gadget-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 -- )
+ >r dup selected-rect rect-bounds 2 v/n v+
+ over visible-dim r> 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
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax ui.gadgets.worlds
+kernel ;
+IN: ui.gadgets.menus
+
+HELP: <commands-menu>
+{ $values { "hook" "a quotation with stack effect " { $snippet "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
+
+HELP: show-menu
+{ $values { "gadget" gadget } { "owner" gadget } }
+{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location." } ;
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays ui.commands 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 ;
+IN: ui.gadgets.menus
+
+: menu-loc ( world menu -- loc )
+ >r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
+
+TUPLE: menu-glass < gadget ;
+
+: <menu-glass> ( menu world -- glass )
+ menu-glass new-gadget
+ >r over menu-loc over set-rect-loc r>
+ [ swap add-gadget drop ] keep ;
+
+M: menu-glass layout* gadget-child prefer ;
+
+: hide-glass ( world -- )
+ dup world-glass [ unparent ] when*
+ f swap set-world-glass ;
+
+: show-glass ( gadget world -- )
+ over hand-clicked set-global
+ [ hide-glass ] keep
+ [ swap add-gadget drop ] 2keep
+ set-world-glass ;
+
+: show-menu ( gadget owner -- )
+ find-world [ <menu-glass> ] keep show-glass ;
+
+\ menu-glass H{
+ { T{ button-down } [ find-world [ hide-glass ] when* ] }
+ { T{ drag } [ update-clicked drop ] }
+} set-gestures
+
+: <menu-item> ( hook target command -- button )
+ dup command-name -rot command-button-quot
+ swapd
+ [ hand-clicked get find-world hide-glass ]
+ 3append <roll-button> ;
+
+: menu-theme ( gadget -- gadget )
+ light-gray solid-interior
+ faint-boundary ;
+
+: <commands-menu> ( hook target commands -- gadget )
+ <filled-pile>
+ -roll
+ [ <menu-item> add-gadget ] with with each
+ 5 <border> menu-theme ;
--- /dev/null
+Menu gadgets pop up as a list of commands at the mouse location
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax generic kernel
+classes.tuple quotations ;
+IN: ui.gadgets.packs
+
+ARTICLE: "ui-pack-layout" "Pack layouts"
+"Pack gadgets layout their children along a single axis."
+{ $subsection pack }
+"Creating empty packs:"
+{ $subsection <pack> }
+{ $subsection <pile> }
+{ $subsection <shelf> }
+
+"For more control, custom layouts can reuse portions of pack layout logic:"
+{ $subsection pack-pref-dim }
+{ $subsection pack-layout } ;
+
+HELP: pack
+{ $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:"
+{ $list
+ { $link <pack> }
+ { $link <pile> }
+ { $link <shelf> }
+}
+"Packs have the following slots:"
+{ $list
+ { { $link pack-align } " a rational number between 0 and 1, the alignment of gadgets along the axis perpendicular to the pack's orientation" }
+ { { $link pack-fill } " a rational number between 0 and 1, where 0 gives each gadget its preferred size and 1 fills the dimension perpendicular to the pack's orientation" }
+ { { $link pack-gap } " a pair of integers, the horizontal and vertical gap between children" }
+}
+"Custom gadgets can inherit from the " { $link pack } " class and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ;
+
+HELP: pack-layout
+{ $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } }
+{ $description "Lays out the pack's children along the " { $link gadget-orientation } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
+{ $notes
+ "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
+} ;
+
+HELP: <pack>
+{ $values { "orientation" "an orientation specifier" } { "pack" "a new " { $link pack } } }
+{ $description "Creates a new pack which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
+
+{ <pack> <pile> <shelf> } related-words
+
+HELP: <pile>
+{ $values { "pack" "a new " { $link pack } } }
+{ $description "Creates a new " { $link pack } " which lays out its children vertically." } ;
+
+HELP: <shelf>
+{ $values { "pack" "a new " { $link pack } } }
+{ $description "Creates a new " { $link pack } " which lays out its children horizontally." } ;
+
+HELP: pack-pref-dim
+{ $values { "gadget" gadget } { "sizes" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
+{ $description "Computes the preferred size of a pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
+{ $notes
+ "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
+} ;
+
+ABOUT: "ui-pack-layout"
--- /dev/null
+IN: ui.gadgets.packs.tests
+USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render
+kernel namespaces tools.test math.parser sequences math.geometry.rect ;
+
+[ t ] [
+ { 0 0 } { 100 100 } <rect> clip set
+
+ <pile>
+ 100 [ number>string <label> add-gadget ] each
+ dup layout
+
+ visible-children [ label? ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences ui.gadgets kernel math math.functions
+math.vectors namespaces math.order accessors math.geometry.rect ;
+IN: ui.gadgets.packs
+
+TUPLE: pack < gadget
+{ align initial: 0 }
+{ fill initial: 0 }
+{ gap initial: { 0 0 } } ;
+
+: packed-dim-2 ( gadget sizes -- list )
+ [ over rect-dim over v- rot pack-fill v*n v+ ] with map ;
+
+: packed-dims ( gadget sizes -- seq )
+ 2dup packed-dim-2 swap orient ;
+
+: gap-locs ( gap sizes -- seq )
+ { 0 0 } [ v+ over v+ ] accumulate 2nip ;
+
+: aligned-locs ( gadget sizes -- seq )
+ [ >r dup pack-align swap rect-dim r> v- n*v ] with map ;
+
+: packed-locs ( gadget sizes -- seq )
+ over pack-gap over gap-locs >r dupd aligned-locs r> orient ;
+
+: round-dims ( seq -- newseq )
+ { 0 0 } swap
+ [ swap v- dup [ ceiling >fixnum ] map [ swap v- ] keep ] map
+ nip ;
+
+: pack-layout ( pack sizes -- )
+ round-dims over gadget-children
+ >r dupd packed-dims r> 2dup [ (>>dim) ] 2each
+ >r packed-locs r> [ set-rect-loc ] 2each ;
+
+: <pack> ( orientation -- pack )
+ pack new-gadget
+ swap >>orientation ;
+
+: <pile> ( -- pack ) { 0 1 } <pack> ;
+
+: <filled-pile> ( -- pack ) <pile> 1 over set-pack-fill ;
+
+: <shelf> ( -- pack ) { 1 0 } <pack> ;
+
+: gap-dims ( gap sizes -- seeq )
+ [ dim-sum ] keep length 1 [-] rot n*v v+ ;
+
+: pack-pref-dim ( gadget sizes -- dim )
+ over pack-gap over gap-dims >r max-dim r>
+ rot gadget-orientation set-axis ;
+
+M: pack pref-dim*
+ dup gadget-children pref-dims pack-pref-dim ;
+
+M: pack layout*
+ dup gadget-children pref-dims pack-layout ;
+
+M: pack children-on ( rect gadget -- seq )
+ dup gadget-orientation swap gadget-children
+ [ fast-children-on ] keep <slice> ;
--- /dev/null
+Pack gadgets arrange children horizontally or vertically
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets models help.markup help.syntax io kernel
+quotations ;
+IN: ui.gadgets.panes
+
+HELP: pane
+{ $class-description "A pane " { $link gadget } " displays formatted text which is written to a " { $link pane-stream } " targetting the pane. Panes are created by calling " { $link <pane> } ", " { $link <scrolling-pane> } " or " { $link <pane-control> } "." } ;
+
+HELP: <pane>
+{ $values { "pane" "a new " { $link pane } } }
+{ $description "Creates a new " { $link pane } " gadget." } ;
+
+HELP: write-gadget
+{ $values { "gadget" gadget } { "stream" "an output stream" } }
+{ $contract "Writes a gadget to the stream." }
+{ $notes "Not all streams support this operation." } ;
+
+{ write-gadget print-gadget gadget. } related-words
+
+HELP: print-gadget
+{ $values { "gadget" gadget } { "stream" "an output stream" } }
+{ $description "Writes a gadget to the stream, followed by a newline." }
+{ $notes "Not all streams support this operation." } ;
+
+HELP: gadget.
+{ $values { "gadget" gadget } }
+{ $description "Writes a gadget followed by a newline to " { $link output-stream } "." }
+{ $notes "Not all streams support this operation." } ;
+
+HELP: ?nl
+{ $values { "stream" pane-stream } }
+{ $description "Inserts a line break in the pane unless the current line is empty." } ;
+
+HELP: with-pane
+{ $values { "pane" pane } { "quot" quotation } }
+{ $description "Clears the pane and calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to the pane." } ;
+
+HELP: make-pane
+{ $values { "quot" quotation } { "gadget" "a new " { $link gadget } } }
+{ $description "Calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to a new pane. The output area of the new pane is output on the stack after the quotation returns. The pane itself is not output." } ;
+
+HELP: <scrolling-pane>
+{ $values { "pane" "a new " { $link pane } } }
+{ $description "Creates a new " { $link pane } " gadget which scrolls any scroll pane containing it to the bottom on output. behaving much like a terminal or logger." } ;
+
+HELP: <pane-control>
+{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
+{ $description "Creates a new control delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
+
+HELP: pane-stream
+{ $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." } ;
+
+HELP: <pane-stream> ( pane -- stream )
+{ $values { "pane" pane } { "stream" "a new " { $link pane-stream } } }
+{ $description "Creates a new " { $link pane-stream } " for writing to " { $snippet "pane" } "." } ;
+
+{ with-pane make-pane } related-words
+
+ARTICLE: "ui.gadgets.panes" "Pane gadgets"
+"A pane displays formatted text."
+{ $subsection pane }
+{ $subsection <pane> }
+{ $subsection <scrolling-pane> }
+{ $subsection <pane-control> }
+"Panes are written to by creating a special output stream:"
+{ $subsection pane-stream }
+{ $subsection <pane-stream> }
+"In addition to the stream output words (" { $link "stream-protocol" } ", pane streams can have gadgets written to them:"
+{ $subsection write-gadget }
+{ $subsection print-gadget }
+{ $subsection gadget. }
+"The " { $link gadget. } " word is useful for interactive debugging of gadgets in the listener."
+$nl
+"There are a few combinators for working with panes:"
+{ $subsection with-pane }
+{ $subsection make-pane } ;
+
+ABOUT: "ui.gadgets.panes"
--- /dev/null
+IN: ui.gadgets.panes.tests
+USING: alien ui.gadgets.panes ui.gadgets namespaces
+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 ;
+
+: #children "pane" get gadget-children length ;
+
+[ ] [ <pane> "pane" set ] unit-test
+
+[ ] [ #children "num-children" set ] unit-test
+
+[ ] [
+ "pane" get <pane-stream> [ 10000 [ . ] each ] with-output-stream*
+] unit-test
+
+[ t ] [ #children "num-children" get = ] unit-test
+
+: test-gadget-text
+ dup make-pane gadget-text dup print "======" print
+ swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
+
+[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
+[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting
+ ] test-gadget-text
+] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [
+ H{ } [
+ "hello" pprint
+ ] with-style
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
+[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
+[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
+[ t ] [ [ \ = see ] test-gadget-text ] unit-test
+[ t ] [ [ \ = help ] test-gadget-text ] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ [ "Hello world" write ] ($block)
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+ARTICLE: "test-article-1" "This is a test article"
+"Hello world, how are you today." ;
+
+[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
+
+[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+
+ARTICLE: "test-article-2" "This is a test article"
+"Hello world, how are you today."
+{ $table { "a" "b" } { "c" "d" } } ;
+
+[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
+
+<pane> [ \ = see ] with-pane
+<pane> [ \ = help ] with-pane
+
+[ ] [
+ \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 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 ui.gadgets.incremental ui.gadgets.packs
+ ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
+ hashtables io kernel namespaces sequences io.styles strings
+ quotations math opengl combinators math.vectors
+ sorting splitting io.streams.nested assocs
+ ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
+ ui.gadgets.grid-lines classes.tuple models continuations
+ destructors accessors math.geometry.rect ;
+
+IN: ui.gadgets.panes
+
+TUPLE: pane < pack
+ output current prototype scrolls?
+ selection-color caret mark selecting? ;
+
+: clear-selection ( pane -- pane ) f >>caret f >>mark ;
+
+: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
+: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
+
+: prepare-line ( pane -- pane )
+ clear-selection
+ dup prototype>> clone add-current ;
+
+: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ;
+
+: selected-children ( pane -- seq )
+ [ pane-caret&mark sort-pair ] keep gadget-subtree ;
+
+M: pane gadget-selection? pane-caret&mark and ;
+
+M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
+
+: pane-clear ( pane -- )
+ clear-selection
+ [ pane-output clear-incremental ]
+ [ pane-current clear-gadget ]
+ bi ;
+
+: new-pane ( class -- pane )
+ new-gadget
+ { 0 1 } >>orientation
+ <shelf> >>prototype
+ <incremental> add-output
+ prepare-line
+ selection-color >>selection-color ;
+
+: <pane> ( -- pane ) pane new-pane ;
+
+GENERIC: draw-selection ( loc obj -- )
+
+: if-fits ( rect quot -- )
+ >r clip get over intersects? r> [ drop ] if ; inline
+
+M: gadget draw-selection ( loc gadget -- )
+ swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;
+
+M: node draw-selection ( loc node -- )
+ 2dup node-value swap offset-rect [
+ drop 2dup
+ [ node-value rect-loc v+ ] keep
+ node-children [ draw-selection ] with each
+ ] if-fits 2drop ;
+
+M: pane draw-gadget*
+ dup gadget-selection? [
+ dup pane-selection-color set-color
+ origin get over rect-loc v- swap selected-children
+ [ draw-selection ] with each
+ ] [
+ drop
+ ] if ;
+
+: scroll-pane ( pane -- )
+ dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
+
+TUPLE: pane-stream pane ;
+
+C: <pane-stream> pane-stream
+
+: smash-line ( current -- gadget )
+ dup gadget-children {
+ { [ dup empty? ] [ 2drop "" <label> ] }
+ { [ dup length 1 = ] [ nip first ] }
+ [ drop ]
+ } cond ;
+
+: smash-pane ( pane -- gadget ) pane-output smash-line ;
+
+: pane-nl ( pane -- pane )
+ dup pane-current dup unparent smash-line
+ over pane-output add-incremental
+ prepare-line ;
+
+: pane-write ( pane seq -- )
+ [ pane-nl ]
+ [ over pane-current stream-write ]
+ interleave drop ;
+
+: pane-format ( style pane seq -- )
+ [ pane-nl ]
+ [ 2over pane-current stream-format ]
+ interleave 2drop ;
+
+GENERIC: write-gadget ( gadget stream -- )
+
+M: pane-stream write-gadget ( gadget pane-stream -- )
+ pane>> current>> swap add-gadget drop ;
+
+M: style-stream write-gadget
+ stream>> write-gadget ;
+
+: print-gadget ( gadget stream -- )
+ tuck write-gadget stream-nl ;
+
+: gadget. ( gadget -- )
+ output-stream get print-gadget ;
+
+: ?nl ( stream -- )
+ dup pane-stream-pane pane-current gadget-children empty?
+ [ dup stream-nl ] unless drop ;
+
+: with-pane ( pane quot -- )
+ over scroll>top
+ over pane-clear >r <pane-stream> r>
+ over >r with-output-stream* r> ?nl ; inline
+
+: make-pane ( quot -- gadget )
+ <pane> [ swap with-pane ] keep smash-pane ; inline
+
+: <scrolling-pane> ( -- pane )
+ <pane> t over set-pane-scrolls? ;
+
+TUPLE: pane-control < pane quot ;
+
+M: pane-control model-changed ( model pane-control -- )
+ [ value>> ] [ dup quot>> ] bi* with-pane ;
+
+: <pane-control> ( model quot -- pane )
+ pane-control new-pane
+ swap >>quot
+ swap >>model ;
+
+: do-pane-stream ( pane-stream quot -- )
+ >r pane-stream-pane r> keep scroll-pane ; inline
+
+M: pane-stream stream-nl
+ [ pane-nl drop ] do-pane-stream ;
+
+M: pane-stream stream-write1
+ [ pane-current stream-write1 ] do-pane-stream ;
+
+M: pane-stream stream-write
+ [ swap string-lines pane-write ] do-pane-stream ;
+
+M: pane-stream stream-format
+ [ rot string-lines pane-format ] do-pane-stream ;
+
+M: pane-stream dispose drop ;
+
+M: pane-stream stream-flush drop ;
+
+M: pane-stream make-span-stream
+ swap <style-stream> <ignore-close-stream> ;
+
+! Character styles
+
+: apply-style ( style gadget key quot -- style gadget )
+ >r pick at r> when* ; inline
+
+: apply-foreground-style ( style gadget -- style gadget )
+ foreground [ over set-label-color ] apply-style ;
+
+: apply-background-style ( style gadget -- style gadget )
+ background [ solid-interior ] apply-style ;
+
+: specified-font ( style -- font )
+ [ font swap at "monospace" or ] keep
+ [ font-style swap at plain or ] keep
+ font-size swap at 12 or 3array ;
+
+: apply-font-style ( style gadget -- style gadget )
+ over specified-font over set-label-font ;
+
+: apply-presentation-style ( style gadget -- style gadget )
+ presented [ <presentation> ] apply-style ;
+
+: style-label ( style gadget -- gadget )
+ apply-foreground-style
+ apply-background-style
+ apply-font-style
+ apply-presentation-style
+ nip ; inline
+
+: <styled-label> ( style text -- gadget )
+ <label> style-label ;
+
+! Paragraph styles
+
+: apply-wrap-style ( style pane -- style pane )
+ wrap-margin [
+ 2dup <paragraph> >>prototype drop
+ <paragraph> >>current
+ ] apply-style ;
+
+: apply-border-color-style ( style gadget -- style gadget )
+ border-color [ solid-boundary ] apply-style ;
+
+: 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 ] curry >>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 ;
+
+: new-nested-pane-stream ( style parent class -- stream )
+ new
+ swap >>parent
+ swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
+ inline
+
+: unnest-pane-stream ( stream -- child parent )
+ dup ?nl
+ dup style>>
+ over pane>> smash-pane style-pane
+ swap parent>> ;
+
+TUPLE: pane-block-stream < nested-pane-stream ;
+
+M: pane-block-stream dispose
+ unnest-pane-stream write-gadget ;
+
+M: pane-stream make-block-stream
+ pane-block-stream new-nested-pane-stream ;
+
+! Tables
+: apply-table-gap-style ( style grid -- style grid )
+ table-gap [ over set-grid-gap ] apply-style ;
+
+: apply-table-border-style ( style grid -- style grid )
+ table-border [ <grid-lines> over set-gadget-boundary ]
+ apply-style ;
+
+: styled-grid ( style grid -- grid )
+ <grid>
+ f over set-grid-fill?
+ apply-table-gap-style
+ apply-table-border-style
+ nip ;
+
+TUPLE: pane-cell-stream < nested-pane-stream ;
+
+M: pane-cell-stream dispose ?nl ;
+
+M: pane-stream make-cell-stream
+ pane-cell-stream new-nested-pane-stream ;
+
+M: pane-stream stream-write-table
+ >r
+ swap [ [ pane-stream-pane smash-pane ] map ] map
+ styled-grid
+ r> print-gadget ;
+
+! Stream utilities
+M: pack dispose drop ;
+
+M: paragraph dispose drop ;
+
+: gadget-write ( string gadget -- )
+ over empty?
+ [ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
+
+M: pack stream-write gadget-write ;
+
+: gadget-bl ( style stream -- )
+ >r " " <word-break-gadget> style-label r> swap add-gadget drop ;
+
+M: paragraph stream-write
+ swap " " split
+ [ H{ } over gadget-bl ] [ over gadget-write ] interleave
+ drop ;
+
+: gadget-write1 ( char gadget -- )
+ >r 1string r> stream-write ;
+
+M: pack stream-write1 gadget-write1 ;
+
+M: paragraph stream-write1
+ over CHAR: \s =
+ [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
+
+: gadget-format ( string style stream -- )
+ pick empty?
+ [ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
+
+M: pack stream-format
+ gadget-format ;
+
+M: paragraph stream-format
+ presented pick at [
+ gadget-format
+ ] [
+ rot " " split
+ [ 2dup gadget-bl ]
+ [ 2over gadget-format ] interleave
+ 2drop
+ ] if ;
+
+: caret>mark ( pane -- pane )
+ dup caret>> >>mark
+ dup relayout-1 ;
+
+GENERIC: sloppy-pick-up* ( loc gadget -- n )
+
+M: pack sloppy-pick-up* ( loc gadget -- n )
+ [ orientation>> ] [ children>> ] bi (fast-children-on) ;
+
+M: gadget sloppy-pick-up*
+ gadget-children [ inside? ] with find-last drop ;
+
+M: f sloppy-pick-up*
+ 2drop f ;
+
+: wet-and-sloppy ( loc gadget n -- newloc newgadget )
+ swap nth-gadget [ rect-loc v- ] keep ;
+
+: sloppy-pick-up ( loc gadget -- path )
+ 2dup sloppy-pick-up* dup
+ [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
+ [ 3drop { } ]
+ if ;
+
+: move-caret ( pane -- pane )
+ dup hand-rel
+ over sloppy-pick-up
+ over set-pane-caret
+ dup relayout-1 ;
+
+: begin-selection ( pane -- )
+ move-caret f swap set-pane-mark ;
+
+: extend-selection ( pane -- )
+ hand-moved? [
+ dup selecting?>> [
+ move-caret
+ ] [
+ dup hand-clicked get child? [
+ t >>selecting?
+ dup hand-clicked set-global
+ move-caret
+ caret>mark
+ ] when
+ ] if
+ dup dup pane-caret gadget-at-path scroll>gadget
+ ] when drop ;
+
+: end-selection ( pane -- )
+ f >>selecting?
+ hand-moved? [
+ [ com-copy-selection ] [ request-focus ] bi
+ ] [
+ relayout-1
+ ] if ;
+
+: select-to-caret ( pane -- )
+ dup pane-mark [ caret>mark ] unless
+ move-caret
+ dup request-focus
+ com-copy-selection ;
+
+pane H{
+ { T{ button-down } [ begin-selection ] }
+ { T{ button-down f { S+ } 1 } [ select-to-caret ] }
+ { T{ button-up f { S+ } 1 } [ drop ] }
+ { T{ button-up } [ end-selection ] }
+ { T{ drag } [ extend-selection ] }
+ { T{ copy-action } [ com-copy ] }
+} set-gestures
--- /dev/null
+Pane gadgets display formatted stream output
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
+namespaces sequences math.order math.geometry.rect ;
+IN: ui.gadgets.paragraphs
+
+! A word break gadget
+TUPLE: word-break-gadget < label ;
+
+: <word-break-gadget> ( text -- gadget )
+ word-break-gadget new-label ;
+
+M: word-break-gadget draw-gadget* drop ;
+
+! A gadget that arranges its children in a word-wrap style.
+TUPLE: paragraph < gadget margin ;
+
+: <paragraph> ( margin -- gadget )
+ paragraph new-gadget
+ { 1 0 } over set-gadget-orientation
+ [ set-paragraph-margin ] keep ;
+
+SYMBOL: x SYMBOL: max-x
+
+SYMBOL: y SYMBOL: max-y
+
+SYMBOL: line-height
+
+SYMBOL: margin
+
+: overrun? ( width -- ? ) x get + margin get > ;
+
+: zero-vars ( seq -- ) [ 0 swap set ] each ;
+
+: wrap-line ( -- )
+ line-height get y +@
+ { x line-height } zero-vars ;
+
+: wrap-pos ( -- pos ) x get y get 2array ; inline
+
+: advance-x ( x -- )
+ x +@
+ x get max-x [ max ] change ;
+
+: advance-y ( y -- )
+ dup line-height [ max ] change
+ y get + max-y [ max ] change ;
+
+: wrap-step ( quot child -- )
+ dup pref-dim [
+ over word-break-gadget? [
+ dup first overrun? [ wrap-line ] when
+ ] unless drop wrap-pos rot call
+ ] keep first2 advance-y advance-x ; inline
+
+: wrap-dim ( -- dim ) max-x get max-y get 2array ;
+
+: init-wrap ( paragraph -- )
+ paragraph-margin margin set
+ { x max-x y max-y line-height } zero-vars ;
+
+: do-wrap ( paragraph quot -- dim )
+ [
+ swap dup init-wrap
+ [ wrap-step ] with each-child wrap-dim
+ ] with-scope ; inline
+
+M: paragraph pref-dim*
+ [ 2drop ] do-wrap ;
+
+M: paragraph layout*
+ [ swap dup prefer set-rect-loc ] do-wrap drop ;
--- /dev/null
+Paragraph gadgets lay out their children from left to right, wrapping at a fixed margin
--- /dev/null
+
+USING: kernel quotations arrays sequences math math.ranges fry
+ opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
+ accessors ;
+
+IN: ui.gadgets.plot
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: plot < cartesian functions points ;
+
+: init-plot ( plot -- plot )
+ init-cartesian
+ { } >>functions
+ 100 >>points ;
+
+: <plot> ( -- plot ) plot new init-plot ;
+
+: step-size ( plot -- step-size )
+ [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ;
+
+: plot-range ( plot -- range )
+ [ x-min>> ] [ x-max>> ] [ step-size ] tri <range> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: function function color ;
+
+GENERIC: plot-function ( plot object -- plot )
+
+M: quotation plot-function ( plot quotation -- plot )
+ >r dup plot-range r> '[ dup @ 2array ] map line-strip ;
+
+M: function plot-function ( plot function -- plot )
+ dup color>> dup [ >stroke-color ] [ drop ] if
+ >r dup plot-range r> function>> '[ dup @ 2array ] map line-strip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ;
+
+: draw-axis ( plot -- plot )
+ dup
+ [ [ x-min>> ] [ drop 0 ] bi 2array ]
+ [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line*
+ dup
+ [ [ drop 0 ] [ y-min>> ] bi 2array ]
+ [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gadgets.slate ;
+
+M: plot draw-slate ( plot -- plot )
+ 2 glLineWidth
+ draw-axis
+ plot-functions
+ fill-mode
+ 1 glLineWidth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-function ( plot function -- plot )
+ over functions>> swap suffix >>functions ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ;
+: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: ui.gestures ui.gadgets ;
+
+: left ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max
+ dup relayout-1 ;
+
+: right ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max
+ dup relayout-1 ;
+
+: down ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max
+ dup relayout-1 ;
+
+: up ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-in-horizontal ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ;
+
+: zoom-in-vertical ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ;
+
+: zoom-in ( plot -- plot )
+ zoom-in-horizontal
+ zoom-in-vertical
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zoom-out-horizontal ( plot -- plot )
+ dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
+ dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ;
+
+: zoom-out-vertical ( plot -- plot )
+ dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
+ dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ;
+
+: zoom-out ( plot -- plot )
+ zoom-out-horizontal
+ zoom-out-vertical
+ dup relayout-1 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+plot
+ H{
+ { T{ mouse-enter } [ request-focus ] }
+ { T{ key-down f f "LEFT" } [ left drop ] }
+ { T{ key-down f f "RIGHT" } [ right drop ] }
+ { T{ key-down f f "DOWN" } [ down drop ] }
+ { T{ key-down f f "UP" } [ up drop ] }
+ { T{ key-down f f "a" } [ zoom-in drop ] }
+ { T{ key-down f f "z" } [ zoom-out drop ] }
+ }
+set-gestures
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets.buttons
+ui.gadgets.menus models ui.operations summary kernel
+ui.gadgets.worlds ui.gadgets ui.gadgets.status-bar ;
+IN: ui.gadgets.presentations
+
+HELP: presentation
+{ $class-description "A presentation is a " { $link button } " which represents an object. Left-clicking a presentation invokes the default " { $link operation } ", and right-clicking displays a menu of possible operations output by " { $link object-operations } "."
+$nl
+"Presentations are created by calling " { $link <presentation> } "."
+$nl
+"Presentations have two slots:"
+{ $list
+ { { $link presentation-object } " - the object being presented." }
+ { { $link presentation-hook } " - a quotation with stack effect " { $snippet "( presentation -- )" } ". The default value is " { $snippet "[ drop ]" } "." }
+} } ;
+
+HELP: invoke-presentation
+{ $values { "presentation" presentation } { "command" "a command" } }
+{ $description "Calls the " { $link presentation-hook } " and then invokes the command on the " { $link presentation-object } "." } ;
+
+{ invoke-presentation invoke-primary invoke-secondary } related-words
+
+HELP: invoke-primary
+{ $values { "presentation" presentation } }
+{ $description "Invokes the " { $link primary-operation } " associated to the " { $link presentation-object } ". This word is executed when the presentation is clicked with the left mouse button." } ;
+
+HELP: invoke-secondary
+{ $values { "presentation" presentation } }
+{ $description "Invokes the " { $link secondary-operation } " associated to the " { $link presentation-object } ". This word is executed when a list receives a " { $snippet "RET" } " key press." } ;
+
+HELP: <presentation>
+{ $values { "label" "a label" } { "object" object } { "button" "a new " { $link button } } }
+{ $description "Creates a new " { $link presentation } " derived from " { $link <roll-button> } "." }
+{ $see-also "presentations" } ;
+
+{ <button> <bevel-button> <command-button> <roll-button> <presentation> } related-words
+
+{ <commands-menu> <toolbar> operations-menu show-menu } related-words
+
+{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
+
+HELP: show-mouse-help
+{ $values { "presentation" presentation } }
+{ $description "Displays a " { $link summary } " of the " { $link presentation-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" } ")."
+{ $subsection presentation }
+{ $subsection <presentation> }
+"Presentations remember the object they are presenting; operations can be performed on the presented object. See " { $link "ui-operations" } "." ;
+
+ABOUT: "ui.gadgets.presentations"
--- /dev/null
+IN: ui.gadgets.presentations.tests
+USING: math ui.gadgets.presentations ui.gadgets tools.test
+prettyprint ui.gadgets.buttons io io.streams.string kernel
+classes.tuple ;
+
+[ t ] [
+ "Hi" \ + <presentation> [ gadget? ] is?
+] unit-test
+
+[ "+" ] [
+ [
+ \ + f \ pprint <command-button> dup button-quot call
+ ] with-string-writer
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors definitions hashtables io kernel
+prettyprint sequences strings io.styles words help math models
+namespaces quotations
+ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
+ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
+IN: ui.gadgets.presentations
+
+TUPLE: presentation < button object hook ;
+
+: invoke-presentation ( presentation command -- )
+ over dup presentation-hook call
+ >r presentation-object r> invoke-command ;
+
+: invoke-primary ( presentation -- )
+ dup presentation-object primary-operation
+ invoke-presentation ;
+
+: invoke-secondary ( presentation -- )
+ dup presentation-object secondary-operation
+ invoke-presentation ;
+
+: show-mouse-help ( presentation -- )
+ dup presentation-object over show-summary button-update ;
+
+: <presentation> ( label object -- button )
+ swap [ invoke-primary ] presentation new-button
+ swap >>object
+ [ drop ] >>hook
+ roll-button-theme ;
+
+M: presentation ungraft*
+ dup hand-gadget get-global child? [ dup hide-status ] when
+ call-next-method ;
+
+: <operations-menu> ( presentation -- menu )
+ dup dup presentation-hook curry
+ swap presentation-object
+ dup object-operations <commands-menu> ;
+
+: operations-menu ( presentation -- )
+ dup <operations-menu> swap show-menu ;
+
+presentation H{
+ { T{ button-down f f 3 } [ operations-menu ] }
+ { T{ mouse-leave } [ dup hide-status button-update ] }
+ { T{ mouse-enter } [ show-mouse-help ] }
+ ! Responding to motion too allows nested presentations to
+ ! display status help properly, when the mouse leaves a
+ ! nested presentation and is still inside the parent, the
+ ! parent doesn't receive a mouse-enter
+ { T{ motion } [ show-mouse-help ] }
+} set-gestures
--- /dev/null
+Presentations display an interactive view of an object
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports
+ui.gadgets.sliders math.geometry.rect ;
+IN: ui.gadgets.scrollers
+
+HELP: scroller
+{ $class-description "A scroller consists of a " { $link viewport } " containing a child, together with horizontal and vertical " { $link slider } " gadgets which scroll the viewport's child. Scroller gadgets also support using a mouse scroll wheel."
+$nl
+"Scroller gadgets are created by calling " { $link <scroller> } "." } ;
+
+HELP: find-scroller
+{ $values { "gadget" gadget } { "scroller/f" "a " { $link scroller } " or " { $link f } } }
+{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
+
+HELP: scroller-value
+{ $values { "scroller" scroller } { "loc" "a pair of integers" } }
+{ $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
+
+{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words
+
+HELP: <scroller>
+{ $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } }
+{ $description "Creates a new " { $link scroller } " for scrolling around " { $snippet "gadget" } "." } ;
+
+{ <viewport> <scroller> } related-words
+
+HELP: scroll
+{ $values { "scroller" scroller } { "value" "a pair of integers" } }
+{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
+
+HELP: relative-scroll-rect
+{ $values { "rect" rect } { "gadget" gadget } { "scroller" scroller } { "newrect" "a new " { $link rect } } }
+{ $description "Adjusts " { $snippet "rect" } " for the case where the gadget is not the immediate child of the scroller's viewport." } ;
+
+HELP: scroll>rect
+{ $values { "rect" rect } { "gadget" gadget } }
+{ $description "Ensures that a rectangular region relative to the top-left corner of " { $snippet "gadget" } " becomes visible in a " { $link scroller } " containing " { $snippet "gadget" } ". Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
+
+HELP: scroll>bottom
+{ $values { "gadget" gadget } }
+{ $description "Ensures that any " { $link scroller } " containing " { $snippet "gadget" } " is scrolled all the way down. Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
+
+HELP: scroll>top
+{ $values { "gadget" gadget } }
+{ $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."
+{ $subsection scroller }
+{ $subsection <scroller> }
+"Getting and setting the scroll position:"
+{ $subsection scroller-value }
+{ $subsection scroll }
+"Writing scrolling-aware gadgets:"
+{ $subsection scroll>bottom }
+{ $subsection scroll>top }
+{ $subsection scroll>rect }
+{ $subsection find-scroller } ;
+
+ABOUT: "ui.gadgets.scrollers"
--- /dev/null
+IN: ui.gadgets.scrollers.tests
+USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
+kernel models models.compose models.range ui.gadgets.viewports
+ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
+ui.gadgets.sliders math math.vectors arrays sequences
+tools.test.ui math.geometry.rect ;
+
+[ ] [
+ <gadget> "g" set
+ "g" get <scroller> "s" set
+] unit-test
+
+[ { 100 200 } ] [
+ { 100 200 } "g" get scroll>rect
+ "s" get scroller-follows rect-loc
+] unit-test
+
+[ ] [ "s" get scroll>bottom ] unit-test
+[ t ] [ "s" get scroller-follows ] unit-test
+
+[ ] [
+ <gadget> dup "g" set
+ 10 1 0 100 <range> 20 1 0 100 <range> 2array <compose>
+ <viewport> "v" set
+] unit-test
+
+"v" get [
+ [ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
+
+ [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+] with-grafted-gadget
+
+[ ] [
+ <gadget> { 100 100 } over set-rect-dim
+ dup "g" set <scroller> "s" set
+] unit-test
+
+[ ] [ { 50 50 } "s" get set-rect-dim ] unit-test
+
+[ ] [ "s" get layout ] unit-test
+
+"s" get [
+ [ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
+
+ [ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
+
+ [ ] [ { 0 0 } "s" get scroll ] unit-test
+
+ [ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
+
+ [ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
+
+ [ ] [ { 10 20 } "s" get scroll ] unit-test
+
+ [ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
+
+ [ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
+
+ [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
+] with-grafted-gadget
+
+<gadget> { 600 400 } over set-rect-dim "g1" set
+<gadget> { 600 10 } over set-rect-dim "g2" set
+"g2" get "g1" get swap add-gadget drop
+
+"g1" get <scroller>
+{ 300 300 } over set-rect-dim
+dup layout
+"s" set
+
+[ t ] [
+ 10 [
+ drop
+ "g2" get scroll>gadget
+ "s" get layout
+ "s" get scroller-value
+ ] map [ { 3 0 } = ] all?
+] unit-test
+
+[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
+
+[ t ] [ "l" get find-scroller "s" get eq? ] unit-test
+[ t ] [ "l" get dup find-scroller scroller-viewport swap child? ] unit-test
+[ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
+[ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
+[ t ] [ "s" get @right grid-child slider? ] unit-test
+[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
+
+\ <scroller> must-infer
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ui.gadgets ui.gadgets.viewports
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
+ui.gadgets.sliders ui.gestures kernel math namespaces sequences
+models models.range models.compose
+combinators math.vectors classes.tuple math.geometry.rect ;
+IN: ui.gadgets.scrollers
+
+TUPLE: scroller < frame viewport x y follows ;
+
+: find-scroller ( gadget -- scroller/f )
+ [ [ scroller? ] is? ] find-parent ;
+
+: scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
+
+: scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
+
+: scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
+
+: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
+
+: do-mouse-scroll ( scroller -- )
+ scroll-direction get-global first2
+ pick scroller-y slide-by-line
+ swap scroller-x slide-by-line ;
+
+scroller H{
+ { T{ mouse-scroll } [ do-mouse-scroll ] }
+} set-gestures
+
+: <scroller-model> ( -- model )
+ 0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
+
+: new-scroller ( gadget class -- scroller )
+ new-frame
+ t >>root?
+ <scroller-model> >>model
+ faint-boundary
+
+ dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
+ dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
+
+ swap over model>> <viewport> >>viewport
+ dup viewport>> @center grid-add ;
+
+: <scroller> ( gadget -- scroller ) scroller new-scroller ;
+
+: scroll ( value scroller -- )
+ [
+ dup scroller-viewport rect-dim { 0 0 }
+ rot scroller-viewport viewport-dim 4array flip
+ ] keep
+ 2dup control-value = [ 2drop ] [ set-control-value ] if ;
+
+: rect-min ( rect1 rect2 -- rect )
+ >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
+
+: (scroll>rect) ( rect scroller -- )
+ [
+ scroller-value vneg offset-rect
+ viewport-gap offset-rect
+ ] keep
+ [ scroller-viewport rect-min ] keep
+ [
+ scroller-viewport 2rect-extent
+ >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
+ ] keep dup scroller-value rot v+ swap scroll ;
+
+: relative-scroll-rect ( rect gadget scroller -- newrect )
+ viewport>> gadget-child relative-loc offset-rect ;
+
+: find-scroller* ( gadget -- scroller )
+ dup find-scroller dup [
+ 2dup scroller-viewport gadget-child
+ swap child? [ nip ] [ 2drop f ] if
+ ] [
+ 2drop f
+ ] if ;
+
+: scroll>rect ( rect gadget -- )
+ dup find-scroller* dup [
+ [ relative-scroll-rect ] keep
+ [ set-scroller-follows ] keep
+ relayout
+ ] [
+ 3drop
+ ] if ;
+
+: (scroll>gadget) ( gadget scroller -- )
+ >r { 0 0 } over pref-dim <rect> swap r>
+ [ relative-scroll-rect ] keep
+ (scroll>rect) ;
+
+: scroll>gadget ( gadget -- )
+ dup find-scroller* dup [
+ [ set-scroller-follows ] keep
+ relayout
+ ] [
+ 2drop
+ ] if ;
+
+: (scroll>bottom) ( scroller -- )
+ dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
+
+: scroll>bottom ( gadget -- )
+ find-scroller [
+ t over set-scroller-follows relayout-1
+ ] when* ;
+
+: scroll>top ( gadget -- )
+ <zero-rect> swap scroll>rect ;
+
+GENERIC: update-scroller ( scroller follows -- )
+
+M: t update-scroller drop (scroll>bottom) ;
+
+M: gadget update-scroller swap (scroll>gadget) ;
+
+M: rect update-scroller swap (scroll>rect) ;
+
+M: f update-scroller drop dup scroller-value swap scroll ;
+
+M: scroller layout*
+ dup call-next-method
+ dup scroller-follows
+ [ update-scroller ] 2keep
+ swap set-scroller-follows ;
+
+M: scroller focusable-child*
+ scroller-viewport ;
+
+M: scroller model-changed
+ nip f swap set-scroller-follows ;
+
+TUPLE: limited-scroller < scroller fixed-dim ;
+
+: <limited-scroller> ( gadget dim -- scroller )
+ >r limited-scroller new-scroller r> >>fixed-dim ;
+
+M: limited-scroller pref-dim*
+ fixed-dim>> ;
--- /dev/null
+Scrollers display a user-chosen portion of a child which may have arbitrary dimensions
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+
+USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
+
+IN: ui.gadgets.slate
+
+TUPLE: slate < gadget action pdim graft ungraft ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-slate ( slate -- slate )
+ init-gadget
+ [ ] >>action
+ { 200 200 } >>pdim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+: <slate> ( action -- slate )
+ slate new
+ init-slate
+ swap >>action ;
+
+M: slate pref-dim* ( slate -- dim ) pdim>> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators arrays sequences math math.geometry
+ opengl.gl ui.gadgets.worlds ;
+
+: screen-y* ( gadget -- loc )
+ {
+ [ find-world height ]
+ [ screen-loc second ]
+ [ height ]
+ }
+ cleave
+ + - ;
+
+: screen-loc* ( gadget -- loc )
+ {
+ [ screen-loc first ]
+ [ screen-y* ]
+ }
+ cleave
+ 2array ;
+
+: setup-viewport ( gadget -- gadget )
+ dup
+ {
+ [ screen-loc* ]
+ [ dim>> ]
+ }
+ cleave
+ gl-viewport ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: default-coordinate-system ( gadget -- gadget )
+ dup
+ {
+ [ drop 0 ]
+ [ width 1 - ]
+ [ height 1 - ]
+ [ drop 0 ]
+ }
+ cleave
+ -1 1
+ glOrtho ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate graft* ( slate -- ) graft>> call ;
+M: slate ungraft* ( slate -- ) ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: establish-coordinate-system ( gadget -- gadget )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate establish-coordinate-system ( slate -- slate )
+ default-coordinate-system ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: draw-slate ( slate -- slate )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-slate ( slate -- slate ) dup action>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: slate draw-gadget* ( slate -- )
+
+ GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
+
+ establish-coordinate-system
+
+ GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
+
+ setup-viewport
+
+ draw-slate
+
+ GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
+ GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
+
+ dup
+ find-world
+ ! The world coordinate system is a little wacky:
+ dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
+ setup-viewport
+ drop
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ui.gadgets models models.range ;
+IN: ui.gadgets.sliders
+
+HELP: elevator
+{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
+
+HELP: find-elevator
+{ $values { "gadget" gadget } { "elevator/f" "an " { $link elevator } " or " { $link f } } }
+{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
+
+HELP: slider
+{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
+$nl
+"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ;
+
+HELP: find-slider
+{ $values { "gadget" gadget } { "slider/f" "a " { $link slider } " or " { $link f } } }
+{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link slider } ". Outputs " { $link f } " if the gadget is not contained in a " { $link slider } "." } ;
+
+HELP: thumb
+{ $class-description "A thumb is the gadget contained in a " { $link slider } "'s " { $link elevator } " which indicates the current scroll position and can be dragged up and down with the mouse." } ;
+
+HELP: slide-by
+{ $values { "amount" "an integer" } { "slider" slider } }
+{ $description "Adds the amount (which may be positive or negative) to the slider's current position." } ;
+
+HELP: slide-by-page
+{ $values { "amount" "an integer" } { "slider" slider } }
+{ $description "Adds the amount multiplied by " { $link slider-page } " to the slider's current position." } ;
+
+HELP: slide-by-line
+{ $values { "amount" "an integer" } { "slider" slider } }
+{ $description "Adds the amount multiplied by " { $link slider-line } " to the slider's current position." } ;
+
+HELP: <slider>
+{ $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } }
+{ $description "Internal word for constructing sliders." }
+{ $notes "This does not build a complete slider, and user code should call " { $link <x-slider> } " or " { $link <y-slider> } " instead." } ;
+
+HELP: <x-slider>
+{ $values { "range" range } { "slider" slider } }
+{ $description "Creates a new horizontal " { $link slider } "." } ;
+
+HELP: <y-slider>
+{ $values { "range" range } { "slider" slider } }
+{ $description "Creates a new vertical " { $link slider } "." } ;
+
+{ <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."
+{ $subsection slider }
+{ $subsection <x-slider> }
+{ $subsection <y-slider> }
+"Changing slider values:"
+{ $subsection slide-by }
+{ $subsection slide-by-line }
+{ $subsection slide-by-page }
+"Since sliders are controls the value can be get and set by calling " { $link gadget-model } "." ;
+
+ABOUT: "ui.gadgets.sliders"
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
+ui.gadgets.frames ui.gadgets.grids math.order
+ui.gadgets.theme ui.render kernel math namespaces sequences
+vectors models models.range math.vectors math.functions
+quotations colors math.geometry.rect ;
+IN: ui.gadgets.sliders
+
+TUPLE: elevator < gadget direction ;
+
+: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
+
+TUPLE: slider < frame elevator thumb saved line ;
+
+: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
+
+: elevator-length ( slider -- n )
+ [ elevator>> dim>> ] [ orientation>> ] bi v. ;
+
+: min-thumb-dim 15 ;
+
+: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
+: slider-page ( gadget -- n ) gadget-model range-page-value ;
+: slider-max ( gadget -- n ) gadget-model range-max-value ;
+: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
+
+: thumb-dim ( slider -- h )
+ dup slider-page over slider-max 1 max / 1 min
+ over elevator-length * min-thumb-dim max
+ over slider-elevator rect-dim
+ rot gadget-orientation v. min ;
+
+: slider-scale ( slider -- n )
+ #! A scaling factor such that if x is a slider co-ordinate,
+ #! x*n is the screen position of the thumb, and conversely
+ #! for x/n. The '1 max' calls avoid division by zero.
+ dup elevator-length over thumb-dim - 1 max
+ swap slider-max* 1 max / ;
+
+: slider>screen ( m scale -- n ) slider-scale * ;
+: screen>slider ( m scale -- n ) slider-scale / ;
+
+M: slider model-changed nip slider-elevator relayout-1 ;
+
+TUPLE: thumb < gadget ;
+
+: begin-drag ( thumb -- )
+ find-slider dup slider-value swap set-slider-saved ;
+
+: do-drag ( thumb -- )
+ find-slider drag-loc over gadget-orientation v.
+ over screen>slider swap [ slider-saved + ] keep
+ gadget-model set-range-value ;
+
+thumb H{
+ { T{ button-down } [ begin-drag ] }
+ { T{ button-up } [ drop ] }
+ { T{ drag } [ do-drag ] }
+} set-gestures
+
+: thumb-theme ( thumb -- thumb )
+ plain-gradient >>interior
+ faint-boundary ; inline
+
+: <thumb> ( vector -- thumb )
+ thumb new-gadget
+ swap >>orientation
+ t >>root?
+ thumb-theme ;
+
+: slide-by ( amount slider -- ) gadget-model move-by ;
+
+: slide-by-page ( amount slider -- ) gadget-model move-by-page ;
+
+: compute-direction ( elevator -- -1/1 )
+ dup find-slider swap hand-click-rel
+ over gadget-orientation v.
+ over screen>slider
+ swap slider-value - sgn ;
+
+: elevator-hold ( elevator -- )
+ dup elevator-direction swap find-slider slide-by-page ;
+
+: elevator-click ( elevator -- )
+ dup compute-direction over set-elevator-direction
+ elevator-hold ;
+
+elevator H{
+ { T{ drag } [ elevator-hold ] }
+ { T{ button-down } [ elevator-click ] }
+} set-gestures
+
+: <elevator> ( vector -- elevator )
+ elevator new-gadget
+ swap >>orientation
+ lowered-gradient >>interior ;
+
+: (layout-thumb) ( slider n -- n thumb )
+ over gadget-orientation n*v swap slider-thumb ;
+
+: thumb-loc ( slider -- loc )
+ dup slider-value swap slider>screen ;
+
+: layout-thumb-loc ( slider -- )
+ dup thumb-loc (layout-thumb)
+ >r [ floor ] map r> set-rect-loc ;
+
+: layout-thumb-dim ( slider -- )
+ dup dup thumb-dim (layout-thumb) >r
+ >r dup rect-dim r>
+ rot gadget-orientation set-axis [ ceiling ] map
+ r> (>>dim) ;
+
+: layout-thumb ( slider -- )
+ dup layout-thumb-loc layout-thumb-dim ;
+
+M: elevator layout*
+ find-slider layout-thumb ;
+
+: slide-by-line ( amount slider -- )
+ [ slider-line * ] keep slide-by ;
+
+: <slide-button> ( vector polygon amount -- button )
+ >r gray swap <polygon-gadget> r>
+ [ swap find-slider slide-by-line ] curry <repeat-button>
+ [ set-gadget-orientation ] keep ;
+
+: elevator, ( gadget orientation -- gadget )
+ tuck <elevator> >>elevator
+ swap <thumb> >>thumb
+ dup elevator>> over thumb>> add-gadget
+ @center grid-add ;
+
+: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
+: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
+: <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ;
+: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
+
+: <slider> ( range orientation -- slider )
+ slider new-frame
+ swap >>orientation
+ swap >>model
+ 32 >>line ;
+
+: <x-slider> ( range -- slider )
+ { 1 0 } <slider>
+ <left-button> @left grid-add
+ { 0 1 } elevator,
+ <right-button> @right grid-add ;
+
+: <y-slider> ( range -- slider )
+ { 0 1 } <slider>
+ <up-button> @top grid-add
+ { 1 0 } elevator,
+ <down-button> @bottom grid-add ;
+
+M: slider pref-dim*
+ dup call-next-method
+ swap gadget-orientation [ 40 v*n ] keep
+ set-axis ;
--- /dev/null
+Slider gadgets provide a graphical view of an integer-valued model
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: ui.gadgets.slots.tests
+USING: assocs ui.gadgets.slots tools.test refs ;
+
+\ <editable-slot> must-infer
+
+[ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 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 ;
+IN: ui.gadgets.slots
+
+TUPLE: update-object ;
+
+TUPLE: update-slot ;
+
+TUPLE: edit-slot ;
+
+TUPLE: slot-editor < track ref text ;
+
+: revert ( slot-editor -- )
+ dup slot-editor-ref get-ref unparse-use
+ swap slot-editor-text set-editor-string ;
+
+\ revert H{
+ { +description+ "Revert any uncomitted changes." }
+} define-command
+
+GENERIC: finish-editing ( slot-editor ref -- )
+
+M: key-ref finish-editing
+ drop T{ update-object } swap send-gesture drop ;
+
+M: value-ref finish-editing
+ drop T{ update-slot } swap send-gesture drop ;
+
+: slot-editor-value ( slot-editor -- object )
+ slot-editor-text control-value parse-fresh ;
+
+: commit ( slot-editor -- )
+ dup slot-editor-text control-value parse-fresh first
+ over slot-editor-ref set-ref
+ dup slot-editor-ref finish-editing ;
+
+\ commit H{
+ { +description+ "Parse the object being edited, and store the result back into the edited slot." }
+} define-command
+
+: com-eval ( slot-editor -- )
+ [ slot-editor-text editor-string eval ] keep
+ [ slot-editor-ref set-ref ] keep
+ dup slot-editor-ref finish-editing ;
+
+\ com-eval H{
+ { +listener+ t }
+ { +description+ "Parse code which evaluates to an object, and store the result back into the edited slot." }
+} define-command
+
+: delete ( slot-editor -- )
+ dup slot-editor-ref delete-ref
+ T{ update-object } swap send-gesture drop ;
+
+\ delete H{
+ { +description+ "Delete the slot and close the slot editor." }
+} define-command
+
+: close ( slot-editor -- )
+ T{ update-slot } swap send-gesture drop ;
+
+\ close H{
+ { +description+ "Close the slot editor without saving changes." }
+} define-command
+
+: <slot-editor> ( ref -- gadget )
+ { 0 1 } slot-editor new-track
+ swap >>ref
+ dup <toolbar> f track-add
+ <source-editor> >>text
+ dup text>> <scroller> 1 track-add
+ dup revert ;
+
+M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
+
+M: slot-editor focusable-child* text>> ;
+
+slot-editor "toolbar" f {
+ { T{ key-down f { C+ } "RET" } commit }
+ { T{ key-down f { S+ C+ } "RET" } com-eval }
+ { f revert }
+ { 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 send-gesture drop ]
+ <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
+Slot editor gadgets are used to implement the UI inspector
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax models
+ui.gadgets ui.gadgets.worlds ;
+IN: ui.gadgets.status-bar
+
+HELP: <status-bar>
+{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." }
+{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
--- /dev/null
+! Copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors models models.delay models.filter
+sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
+ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
+IN: ui.gadgets.status-bar
+
+: <status-bar> ( model -- gadget )
+ 1/10 seconds <delay> [ "" like ] <filter> <label-control>
+ reverse-video-theme
+ t >>root? ;
+
+: open-status-window ( gadget title -- )
+ f <model> [ <world> ] keep
+ <status-bar> f track-add
+ open-world-window ;
+
+: show-summary ( object gadget -- )
+ >r [ summary ] [ "" ] if* r> show-status ;
--- /dev/null
+Status bar gadgets display mouse-over help for other gadgets
--- /dev/null
+Gadget hierarchy and layout management
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+Tabbed windows
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
+ hashtables models models.range models.compose combinators\r
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
+ ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
+\r
+IN: ui.gadgets.tabs\r
+\r
+TUPLE: tabbed < frame names toggler content ;\r
+\r
+DEFER: (del-page)\r
+\r
+:: add-toggle ( model n name toggler -- )\r
+ <frame>\r
+ n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>\r
+ @right grid-add\r
+ n model name <toggle-button> @center grid-add\r
+ toggler swap add-gadget drop ;\r
+\r
+: redo-toggler ( tabbed -- )\r
+ [ names>> ] [ model>> ] [ toggler>> ] tri\r
+ [ clear-gadget ] keep\r
+ [ [ length ] keep ] 2dip\r
+ '[ , _ _ , add-toggle ] 2each ;\r
+\r
+: refresh-book ( tabbed -- )\r
+ model>> [ ] change-model ;\r
+\r
+: (del-page) ( n name tabbed -- )\r
+ { [ [ remove ] change-names redo-toggler ]\r
+ [ dupd [ names>> length ] [ model>> ] bi\r
+ [ [ = ] keep swap [ 1- ] when\r
+ [ < ] keep swap [ 1- ] when ] change-model ]\r
+ [ content>> nth-gadget unparent ]\r
+ [ refresh-book ]\r
+ } cleave ;\r
+\r
+: add-page ( page name tabbed -- )\r
+ [ names>> push ] 2keep\r
+ [ [ model>> swap ]\r
+ [ names>> length 1 - swap ]\r
+ [ toggler>> ] tri add-toggle ]\r
+ [ content>> swap add-gadget drop ]\r
+ [ refresh-book ] tri ;\r
+\r
+: del-page ( name tabbed -- )\r
+ [ names>> index ] 2keep (del-page) ;\r
+\r
+: <tabbed> ( assoc -- tabbed )\r
+ tabbed new-frame\r
+ 0 <model> >>model\r
+ <pile> 1 >>fill >>toggler\r
+ dup toggler>> @left grid-add\r
+ swap\r
+ [ keys >vector >>names ]\r
+ [ values over model>> <book> >>content dup content>> @center grid-add ]\r
+ bi\r
+ dup redo-toggler ;\r
+ \r
--- /dev/null
+Slava Pestov
--- /dev/null
+Common colors and gradients used by the UI
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2006, 2007 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel sequences io.styles ui.gadgets ui.render
+colors accessors ;
+IN: ui.gadgets.theme
+
+: solid-interior ( gadget color -- gadget )
+ <solid> >>interior ; inline
+
+: solid-boundary ( gadget color -- gadget )
+ <solid> >>boundary ; inline
+
+: faint-boundary ( gadget -- gadget )
+ gray solid-boundary ; inline
+
+: selection-color ( -- color ) light-purple ;
+
+: plain-gradient
+ T{ gradient f {
+ T{ gray f 0.94 1.0 }
+ T{ gray f 0.83 1.0 }
+ T{ gray f 0.83 1.0 }
+ T{ gray f 0.62 1.0 }
+ } } ;
+
+: rollover-gradient
+ T{ gradient f {
+ T{ gray f 1.0 1.0 }
+ T{ gray f 0.9 1.0 }
+ T{ gray f 0.9 1.0 }
+ T{ gray f 0.75 1.0 }
+ } } ;
+
+: pressed-gradient
+ T{ gradient f {
+ T{ gray f 0.75 1.0 }
+ T{ gray f 0.9 1.0 }
+ T{ gray f 0.9 1.0 }
+ T{ gray f 1.0 1.0 }
+ } } ;
+
+: selected-gradient
+ T{ gradient f {
+ T{ gray f 0.65 1.0 }
+ T{ gray f 0.8 1.0 }
+ T{ gray f 0.8 1.0 }
+ T{ gray f 1.0 1.0 }
+ } } ;
+
+: lowered-gradient
+ T{ gradient f {
+ T{ gray f 0.37 1.0 }
+ T{ gray f 0.43 1.0 }
+ T{ gray f 0.5 1.0 }
+ } } ;
+
+: sans-serif-font { "sans-serif" plain 12 } ;
+
+: monospace-font { "monospace" plain 12 } ;
--- /dev/null
+
+USING: kernel sequences math math.order
+ ui.gadgets ui.gadgets.tracks ui.gestures
+ fry accessors ;
+
+IN: ui.gadgets.tiling
+
+TUPLE: tiling < track gadgets tiles first focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-tiling ( tiling -- tiling )
+ init-track
+ { 1 0 } >>orientation
+ V{ } clone >>gadgets
+ 2 >>tiles
+ 0 >>first
+ 0 >>focused ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <tiling> ( -- gadget ) tiling new init-tiling ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bounded-subseq ( seq a b -- seq )
+ [ 0 max ] dip
+ pick length [ min ] curry bi@
+ rot
+ subseq ;
+
+: tiling-gadgets-to-map ( tiling -- gadgets )
+ [ gadgets>> ]
+ [ first>> ]
+ [ [ first>> ] [ tiles>> ] bi + ]
+ tri
+ bounded-subseq ;
+
+: tiling-map-gadgets ( tiling -- tiling )
+ dup clear-track
+ dup tiling-gadgets-to-map [ 1 track-add ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: tiling-add ( tiling gadget -- tiling )
+ over gadgets>> push
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: first-gadget ( tiling -- index ) drop 0 ;
+
+: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
+
+: first-viewable ( tiling -- index ) first>> ;
+
+: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-focused-mapped ( tiling -- tiling )
+
+ dup [ focused>> ] [ first>> ] bi <
+ [ dup first>> 1 - >>first ]
+ [ ]
+ if
+
+ dup [ last-viewable ] [ focused>> ] bi <
+ [ dup first>> 1 + >>first ]
+ [ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: check-focused-bounds ( tiling -- tiling )
+ dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
+
+: focus-prev ( tiling -- tiling )
+ dup focused>> 1 - >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+: focus-next ( tiling -- tiling )
+ dup focused>> 1 + >>focused
+ check-focused-bounds
+ make-focused-mapped
+ tiling-map-gadgets
+ dup request-focus ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: exchanged! ( seq a b -- )
+ [ 0 max ] bi@
+ pick length 1 - '[ , min ] bi@
+ rot exchange ;
+
+: move-prev ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
+ focus-prev ;
+
+: move-next ( tiling -- tiling )
+ dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
+ focus-next ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-tile ( tiling -- tiling )
+ dup tiles>> 1 + >>tiles
+ tiling-map-gadgets ;
+
+: del-tile ( tiling -- tiling )
+ dup tiles>> 1 - 1 max >>tiles
+ tiling-map-gadgets ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: tiling focusable-child* ( tiling -- child/t )
+ [ focused>> ] [ gadgets>> ] bi nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: tiling-shelf < tiling ;
+TUPLE: tiling-pile < tiling ;
+
+: <tiling-shelf> ( -- gadget )
+ tiling-shelf new init-tiling { 1 0 } >>orientation ;
+
+: <tiling-pile> ( -- gadget )
+ tiling-pile new init-tiling { 0 1 } >>orientation ;
+
+tiling-shelf
+ H{
+ { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
+
+tiling-pile
+ H{
+ { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
+ { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
+ { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
+ { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
+ { T{ key-down f { C+ } "[" } [ del-tile drop ] }
+ { T{ key-down f { C+ } "]" } [ add-tile drop ] }
+ }
+set-gestures
--- /dev/null
+Slava Pestov
--- /dev/null
+Track gadgets arrange children horizontally or vertically, giving each child a specified fraction of total available space
--- /dev/null
+USING: ui.gadgets.packs help.markup help.syntax ui.gadgets
+arrays kernel quotations classes.tuple ;
+IN: ui.gadgets.tracks
+
+ARTICLE: "ui-track-layout" "Track layouts"
+"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
+{ $subsection track }
+"Creating empty tracks:"
+{ $subsection <track> }
+"Adding children:"
+{ $subsection track-add } ;
+
+HELP: track
+{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
+
+HELP: <track>
+{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
+{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
+
+HELP: track-add
+{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
+{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
+
+ABOUT: "ui-track-layout"
--- /dev/null
+USING: kernel ui.gadgets ui.gadgets.tracks tools.test
+ math.geometry.rect accessors ;
+IN: ui.gadgets.tracks.tests
+
+[ { 100 100 } ] [
+ { 0 1 } <track>
+ <gadget> { 100 100 } >>dim 1 track-add
+ pref-dim
+] unit-test
+
+[ { 100 110 } ] [
+ { 0 1 } <track>
+ <gadget> { 10 10 } >>dim f track-add
+ <gadget> { 100 100 } >>dim 1 track-add
+ pref-dim
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io kernel math namespaces
+ sequences words math.vectors ui.gadgets ui.gadgets.packs
+ math.geometry.rect fry ;
+
+IN: ui.gadgets.tracks
+
+TUPLE: track < pack sizes ;
+
+: normalized-sizes ( track -- seq )
+ sizes>> dup sift sum '[ dup [ , / ] when ] map ;
+
+: init-track ( track -- track )
+ init-gadget
+ V{ } clone >>sizes
+ 1 >>fill ;
+
+: new-track ( orientation class -- track )
+ new
+ init-track
+ swap >>orientation ;
+
+: <track> ( orientation -- track ) track new-track ;
+
+: alloted-dim ( track -- dim )
+ [ children>> ] [ sizes>> ] bi { 0 0 }
+ [ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
+
+: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
+
+: track-layout ( track -- sizes )
+ [ available-dim ] [ children>> ] [ normalized-sizes ] tri
+ [ [ over n*v ] [ pref-dim ] ?if ] 2map nip ;
+
+M: track layout* ( track -- ) dup track-layout pack-layout ;
+
+: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
+
+: track-pref-dims-2 ( track -- dim )
+ [ children>> pref-dims ] [ normalized-sizes ] bi
+ [ [ v/n ] when* ] 2map
+ max-dim
+ [ >fixnum ] map ;
+
+M: track pref-dim* ( gadget -- dim )
+ [ track-pref-dims-1 ]
+ [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
+ [ orientation>> ]
+ tri
+ set-axis ;
+
+: track-add ( track gadget constraint -- track )
+ pick sizes>> push add-gadget ;
+
+: track-remove ( track gadget -- track )
+ dupd dup
+ [
+ [ swap children>> index ]
+ [ unparent sizes>> ] 2bi
+ delete-nth
+ ]
+ [ 2drop ]
+ if ;
+
+: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Viewport gadgets display a portion of a child gadget and are used to implement scrollers
--- /dev/null
+USING: help.markup help.syntax ui.gadgets models ;
+IN: ui.gadgets.viewports
+
+HELP: viewport
+{ $class-description "A viewport is a control which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ;
+
+HELP: <viewport>
+{ $values { "content" gadget } { "model" model } { "viewport" "a new " { $link viewport } } }
+{ $description "Creates a new " { $link viewport } " containing " { $snippet "content" } "." } ;
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: ui.gadgets.viewports
+USING: accessors arrays ui.gadgets ui.gadgets.borders
+kernel math namespaces sequences models math.vectors math.geometry.rect ;
+
+: viewport-gap { 3 3 } ; inline
+
+TUPLE: viewport < gadget ;
+
+: find-viewport ( gadget -- viewport )
+ [ viewport? ] find-parent ;
+
+: viewport-dim ( viewport -- dim )
+ gadget-child pref-dim viewport-gap 2 v*n v+ ;
+
+: <viewport> ( content model -- viewport )
+ viewport new-gadget
+ swap >>model
+ t >>clipped?
+ [ swap add-gadget drop ] keep ;
+
+M: viewport layout*
+ dup rect-dim viewport-gap 2 v*n v-
+ over gadget-child pref-dim vmax
+ swap gadget-child (>>dim) ;
+
+M: viewport focusable-child*
+ gadget-child ;
+
+M: viewport pref-dim* viewport-dim ;
+
+: scroller-value ( scroller -- loc )
+ gadget-model range-value [ >fixnum ] map ;
+
+M: viewport model-changed
+ nip
+ dup relayout-1
+ dup scroller-value
+ vneg viewport-gap v+
+ swap gadget-child set-rect-loc ;
+
+: visible-dim ( gadget -- dim )
+ dup gadget-parent viewport? [
+ gadget-parent rect-dim viewport-gap 2 v*n v-
+ ] [
+ rect-dim
+ ] if ;
--- /dev/null
+Slava Pestov
--- /dev/null
+World gadgets are the top level of the gadget hierarchy and are displayed in native windows
--- /dev/null
+USING: ui.gadgets ui.render ui.gestures ui.backend help.markup
+help.syntax models opengl strings ;
+IN: ui.gadgets.worlds
+
+HELP: origin
+{ $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ;
+
+HELP: hand-world
+{ $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ;
+
+HELP: set-title
+{ $values { "string" string } { "world" world } }
+{ $description "Sets the title bar of the native window containing the world." }
+{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
+
+HELP: select-gl-context
+{ $values { "handle" "a backend-specific handle" } }
+{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
+
+HELP: flush-gl-context
+{ $values { "handle" "a backend-specific handle" } }
+{ $description "Ensures all GL rendering calls made to an OpenGL context finish rendering to the screen. This word is called automatically by the UI after drawing a " { $link world } "." } ;
+
+HELP: focus-path
+{ $values { "world" world } { "seq" "a new sequence" } }
+{ $description "If the top-level window containing the world has focus, outputs a sequence of parents of the currently focused gadget, otherwise outputs " { $link f } "." }
+{ $notes "This word is used to avoid sending " { $link gain-focus } " gestures to a gadget which requests focus on an unfocused top-level window, so that, for instance, a text editing caret does not appear in this case." } ;
+
+HELP: world
+{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds have the following slots:"
+ { $list
+ { { $snippet "active?" } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
+ { { $snippet "glass" } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }
+ { { $snippet "title" } " - a string to be displayed in the title bar of the native window containing the world." }
+ { { $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 "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." }
+ }
+} ;
+
+HELP: <world>
+{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } }
+{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
+
+HELP: find-world
+{ $values { "gadget" gadget } { "world" "a " { $link world } " or " { $link f } } }
+{ $description "Finds the " { $link world } " containing the gadget, or outputs " { $link f } " if the gadget is not grafted." } ;
+
+HELP: draw-world
+{ $values { "world" world } }
+{ $description "Redraws a world." }
+{ $notes "This word should only be called by the UI backend. To force a gadget to redraw from user code, call " { $link relayout-1 } "." } ;
--- /dev/null
+IN: ui.gadgets.worlds.tests
+USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
+namespaces models kernel ;
+
+! Test focus behavior
+<gadget> "g1" set
+
+: <test-world> ( gadget -- world )
+ "Hi" f <world> ;
+
+[ ] [
+ "g1" get <test-world> "w" set
+] unit-test
+
+[ ] [ "g1" get request-focus ] unit-test
+
+[ t ] [ "w" get gadget-focus "g1" get eq? ] unit-test
+
+<gadget> "g1" set
+<gadget> "g2" set
+"g1" get "g2" get swap add-gadget drop
+
+[ ] [
+ "g2" get <test-world> "w" set
+] unit-test
+
+[ ] [ "g1" get request-focus ] unit-test
+
+[ t ] [ "w" get gadget-focus "g2" get eq? ] unit-test
+[ t ] [ "g2" get gadget-focus "g1" get eq? ] unit-test
+[ f ] [ "g1" get gadget-focus ] unit-test
+
+<gadget> "g1" set
+<gadget> "g2" set
+<gadget> "g3" set
+"g1" get "g3" get swap add-gadget drop
+"g2" get "g3" get swap add-gadget drop
+
+[ ] [
+ "g3" get <test-world> "w" set
+] unit-test
+
+[ ] [ "g1" get request-focus ] unit-test
+[ ] [ "g2" get unparent ] unit-test
+[ t ] [ "g3" get gadget-focus "g1" get eq? ] unit-test
+
+[ t ] [ <gadget> dup <test-world> focusable-child eq? ] unit-test
+
+TUPLE: focusing < gadget ;
+
+: <focusing>
+ focusing new-gadget ;
+
+TUPLE: focus-test < gadget ;
+
+: <focus-test>
+ focus-test new-gadget
+ <focusing> over swap add-gadget drop ;
+
+M: focus-test focusable-child* gadget-child ;
+
+<focus-test> "f" set
+
+[ ] [ "f" get <test-world> request-focus ] unit-test
+
+[ t ] [ "f" get gadget-focus "f" get gadget-child eq? ] unit-test
+
+[ t ] [ "f" get gadget-child focusing? ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs continuations kernel math models
+namespaces opengl sequences io combinators math.vectors
+ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
+debugger math.geometry.rect ;
+IN: ui.gadgets.worlds
+
+TUPLE: world < track
+active? focused?
+glass
+title status
+fonts handle
+window-loc ;
+
+: find-world ( gadget -- world ) [ world? ] find-parent ;
+
+M: f world-status ;
+
+: show-status ( string/f gadget -- )
+ find-world world-status [ set-model ] [ drop ] if* ;
+
+: hide-status ( gadget -- ) f swap show-status ;
+
+: (request-focus) ( child world ? -- )
+ pick gadget-parent pick eq? [
+ >r >r dup gadget-parent dup r> r>
+ [ (request-focus) ] keep
+ ] unless focus-child ;
+
+M: world request-focus-on ( child gadget -- )
+ 2dup eq?
+ [ 2drop ] [ dup world-focused? (request-focus) ] if ;
+
+: <world> ( gadget title status -- world )
+ { 0 1 } world new-track
+ t >>root?
+ t >>active?
+ H{ } clone >>fonts
+ { 0 0 } >>window-loc
+ swap >>status
+ swap >>title
+ swap 1 track-add
+ dup request-focus ;
+
+M: world layout*
+ dup call-next-method
+ dup world-glass [
+ >r dup rect-dim r> (>>dim)
+ ] when* drop ;
+
+M: world focusable-child* gadget-child ;
+
+M: world children-on nip gadget-children ;
+
+: (draw-world) ( world -- )
+ dup world-handle [
+ [ dup init-gl ] keep draw-gadget
+ ] with-gl-context ;
+
+: draw-world? ( world -- ? )
+ #! We don't draw deactivated worlds, or those with 0 size.
+ #! On Windows, the latter case results in GL errors.
+ dup world-active?
+ over world-handle
+ rot rect-dim [ 0 > ] all? and and ;
+
+TUPLE: world-error error world ;
+
+C: <world-error> world-error
+
+SYMBOL: ui-error-hook
+
+: ui-error ( error -- )
+ ui-error-hook get [ call ] [ print-error ] if* ;
+
+[ rethrow ] ui-error-hook set-global
+
+: draw-world ( world -- )
+ dup draw-world? [
+ dup world [
+ [
+ (draw-world)
+ ] [
+ over <world-error> ui-error
+ f swap set-world-active?
+ ] recover
+ ] with-variable
+ ] [
+ drop
+ ] if ;
+
+world H{
+ { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
+ { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
+ { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
+ { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
+ { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
+ { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
+ { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
+ { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
+} set-gestures
+
+: close-global ( world global -- )
+ dup get-global find-world rot eq?
+ [ f swap set-global ] [ drop ] if ;
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ui.gadgets kernel ;
+
+IN: ui.gadgets.wrappers
+
+TUPLE: wrapper < gadget ;
+
+: new-wrapper ( child class -- wrapper ) new-gadget swap add-gadget ;
+
+: <wrapper> ( child -- border ) wrapper new-wrapper ;
+
+M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
+
+M: wrapper layout* ( wrapper -- ) [ dim>> ] [ gadget-child ] bi (>>dim) ;
+
+M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax hashtables
+strings kernel system ;
+IN: ui.gestures
+
+HELP: set-gestures
+{ $values { "class" "a class word" } { "hash" hashtable } }
+{ $description "Sets the gestures a gadget class responds to. The hashtable maps gestures to quotations with stack effect " { $snippet "( gadget -- )" } "." } ;
+
+HELP: handle-gesture*
+{ $values { "gadget" "the receiver of the gesture" } { "gesture" "a gesture" } { "delegate" "an object" } { "?" "a boolean" } }
+{ $contract "Handles a gesture sent to a gadget. As the delegation chain is traversed, this generic word is called with every delegate of the gadget at the top of the stack, however the front-most delegate remains fixed as the " { $snippet "gadget" } " parameter."
+$nl
+"Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's delegate." }
+{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ;
+
+HELP: handle-gesture
+{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
+{ $description "Calls " { $link handle-gesture* } " on every delegate of " { $snippet "gadget" } ". Outputs " { $link f } " if some delegate handled the gesture, else outputs " { $link t } "." } ;
+
+{ send-gesture handle-gesture handle-gesture* set-gestures } related-words
+
+HELP: send-gesture
+{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
+{ $description "Calls " { $link send-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
+
+HELP: user-input
+{ $values { "str" string } { "gadget" gadget } }
+{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
+
+HELP: motion
+{ $class-description "Mouse motion gesture." }
+{ $examples { $code "T{ motion }" } } ;
+
+HELP: drag
+{ $class-description "Mouse drag gesture. The " { $link drag-# } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ;
+
+HELP: button-up
+{ $class-description "Mouse button up gesture. Instances have two slots:"
+ { $list
+ { { $link button-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+ { { $link button-up-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
+ }
+}
+{ $examples { $code "T{ button-up f f 1 }" "T{ button-up }" } } ;
+
+HELP: button-down
+{ $class-description "Mouse button down gesture. Instances have two slots:"
+ { $list
+ { { $link button-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+ { { $link button-down-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
+ }
+}
+{ $examples { $code "T{ button-down f f 1 }" "T{ button-down }" } } ;
+
+HELP: mouse-scroll
+{ $class-description "Scroll wheel motion gesture. When this gesture is sent, the " { $link scroll-direction } " global variable is set to a direction vector." }
+{ $examples { $code "T{ mouse-scroll }" } } ;
+
+HELP: mouse-enter
+{ $class-description "Gesture sent when the mouse enters the bounds of a gadget." }
+{ $examples { $code "T{ mouse-enter }" } } ;
+
+HELP: mouse-leave
+{ $class-description "Gesture sent when the mouse leaves the bounds of a gadget." }
+{ $examples { $code "T{ mouse-leave }" } } ;
+
+HELP: gain-focus
+{ $class-description "Gesture sent when a gadget gains keyboard focus." }
+{ $examples { $code "T{ gain-focus }" } } ;
+
+HELP: lose-focus
+{ $class-description "Gesture sent when a gadget loses keyboard focus." }
+{ $examples { $code "T{ lose-focus }" } } ;
+
+HELP: cut-action
+{ $class-description "Gesture sent when the " { $emphasis "cut" } " standard window system action is invoked." }
+{ $examples { $code "T{ cut-action }" } } ;
+
+HELP: copy-action
+{ $class-description "Gesture sent when the " { $emphasis "copy" } " standard window system action is invoked." }
+{ $examples { $code "T{ copy-action }" } } ;
+
+HELP: paste-action
+{ $class-description "Gesture sent when the " { $emphasis "paste" } " standard window system action is invoked." }
+{ $examples { $code "T{ paste-action }" } } ;
+
+HELP: delete-action
+{ $class-description "Gesture sent when the " { $emphasis "delete" } " standard window system action is invoked." }
+{ $examples { $code "T{ delete-action }" } } ;
+
+HELP: select-all-action
+{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
+{ $examples { $code "T{ select-all-action }" } } ;
+
+HELP: generalize-gesture
+{ $values { "gesture" "a gesture" } { "newgesture" "a new gesture" } }
+{ $description "Turns a " { $link button-down } ", " { $link button-up } " or " { $link drag } " action naming a specific mouse button into one which can apply regardless of which mouse button was pressed." } ;
+
+HELP: C+
+{ $description "Control key modifier." } ;
+
+HELP: A+
+{ $description "Alt key modifier." } ;
+
+HELP: M+
+{ $description "Meta key modifier. This is the Command key on Mac OS X." } ;
+
+HELP: S+
+{ $description "Shift key modifier." } ;
+
+HELP: key-down
+{ $class-description "Key down gesture. Instances have two slots:"
+ { $list
+ { { $link key-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+ { { $link key-down-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
+ }
+}
+{ $examples { $code "T{ key-down f { C+ } \"a\" }" "T{ key-down f f \"TAB\" }" } } ;
+
+HELP: key-up
+{ $class-description "Key up gesture. Instances have two slots:"
+ { $list
+ { { $link key-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+ { { $link key-up-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
+ }
+}
+{ $examples { $code "T{ key-up f { C+ } \"a\" }" "T{ key-up f f \"TAB\" }" } } ;
+
+HELP: hand-gadget
+{ $var-description "Global variable. The gadget at the mouse location." } ;
+
+HELP: hand-loc
+{ $var-description "Global variable. The mouse location relative to the top-left corner of the " { $link hand-world } "." } ;
+
+{ hand-loc hand-rel } related-words
+
+HELP: hand-clicked
+{ $var-description "Global variable. The gadget at the location of the most recent click." } ;
+
+HELP: hand-click-loc
+{ $var-description "Global variable. The mouse location at the time of the most recent click relative to the top-left corner of the " { $link hand-world } "." } ;
+
+{ hand-clicked hand-click-loc } related-words
+
+HELP: hand-click#
+{ $var-description "Global variable. The number of times the mouse was clicked in short succession. This counter is reset when " { $link double-click-timeout } " expires." } ;
+
+HELP: hand-last-button
+{ $var-description "Global variable. The mouse button most recently pressed." } ;
+
+HELP: hand-last-time
+{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link millis } "." } ;
+
+HELP: hand-buttons
+{ $var-description "Global variable. A vector of mouse buttons currently held down." } ;
+
+HELP: scroll-direction
+{ $var-description "Global variable. If the most recent gesture was a " { $link mouse-scroll } ", this holds a pair of integers indicating the direction of the scrolling as a two-dimensional vector." } ;
+
+HELP: double-click-timeout
+{ $var-description "Global variable. The maximum delay between two button presses which will still increment " { $link hand-click# } "." } ;
+
+HELP: button-gesture
+{ $values { "gesture" "a gesture" } }
+{ $description "Sends a gesture to the most recently clicked gadget, and if the gadget does not respond to the gesture, removes specific button number information from the gesture and sends it again." } ;
+
+HELP: fire-motion
+{ $description "Sends a " { $link motion } " or " { $link drag } " gesture to the gadget under the mouse, depending on whether a mouse button is being held down or not." } ;
+
+HELP: forget-rollover
+{ $description "Sends " { $link mouse-leave } " gestures to all gadgets containing the gadget under the mouse, and resets the " { $link hand-gadget } " variable." } ;
+
+HELP: request-focus
+{ $values { "gadget" gadget } }
+{ $description "Gives keyboard focus to the " { $link focusable-child } " of the gadget. This may result in " { $link lose-focus } " and " { $link gain-focus } " gestures being sent." } ;
+
+HELP: drag-loc
+{ $values { "loc" "a pair of integers" } }
+{ $description "Outputs the distance travelled by the mouse since the most recent press. Only meaningful inside a " { $link drag } " gesture handler." } ;
+
+HELP: hand-rel
+{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
+{ $description "Outputs the location of the mouse relative to the top-left corner of the gadget. Only meaningful inside a " { $link button-down } ", " { $link button-up } ", " { $link motion } " or " { $link drag } " gesture handler, where the gadget is contained in the same world as the gadget receiving the gesture." } ;
+
+HELP: hand-click-rel
+{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
+{ $description "Outputs the location of the last mouse relative to the top-left corner of the gadget. Only meaningful inside a " { $link button-down } ", " { $link button-up } ", " { $link motion } " or " { $link drag } " gesture handler, where the gadget is contained in the same world as the gadget receiving the gesture." } ;
+
+HELP: under-hand
+{ $values { "seq" "a new sequence" } }
+{ $description "Outputs a sequence where the first element is the " { $link hand-world } " and the last is the " { $link hand-gadget } ", with all parents in between." } ;
+
+HELP: gesture>string
+{ $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } }
+{ $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." }
+{ $examples
+ { $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" }
+} ;
+
+ARTICLE: "ui-gestures" "UI gestures"
+"User actions such as keyboard input and mouse button clicks deliver " { $emphasis "gestures" } " to gadgets. If the direct receiver of the gesture does not handle it, the gesture is passed on to the receiver's parent, and this way it travels up the gadget hierarchy. Gestures which are not handled at some point are ignored."
+$nl
+"There are two ways to define gesture handling logic. The simplest way is to associate a fixed set of gestures with a class:"
+{ $subsection set-gestures }
+"Another way is to define a generic word on a class which handles all gestures sent to gadgets of that class:"
+{ $subsection handle-gesture* }
+"Sometimes a gesture needs to be presented to the user:"
+{ $subsection gesture>string }
+"Keyboard input:"
+{ $subsection "ui-focus" }
+{ $subsection "keyboard-gestures" }
+{ $subsection "action-gestures" }
+{ $subsection "ui-user-input" }
+"Mouse input:"
+{ $subsection "mouse-gestures" }
+"Abstractions built on top of gestures:"
+{ $subsection "ui-commands" }
+{ $subsection "ui-operations" } ;
+
+ARTICLE: "ui-focus" "Keyboard focus"
+"The gadget with keyboard focus is the current receiver of keyboard gestures and user input. Gadgets that wish to receive keyboard input should request focus when clicked:"
+{ $subsection request-focus }
+"The following example demonstrates defining a handler for a mouse click gesture which requests focus:"
+{ $code
+ "my-gadget H{"
+ " { T{ button-down } [ request-focus ] }"
+ "} set-gestures"
+}
+"To nominate a single child as the default focusable child, implement a method on a generic word:"
+{ $subsection focusable-child* }
+"Gestures are sent to a gadget when it gains or loses focus; this can be used to change the gadget's appearance, for example by displaying a border:"
+{ $subsection gain-focus }
+{ $subsection lose-focus } ;
+
+ARTICLE: "keyboard-gestures" "Keyboard gestures"
+"There are two types of keyboard gestures:"
+{ $subsection key-down }
+{ $subsection key-up }
+"Each keyboard gesture has a set of modifiers and a key symbol. The set modifiers is denoted by an array which must either be " { $link f } ", or an order-preserving subsequence of the following:"
+{ $code "{ S+ C+ A+ M+ }" }
+{ $subsection S+ }
+{ $subsection C+ }
+{ $subsection A+ }
+{ $subsection M+ }
+"A key symbol is either a single-character string denoting literal input, or one of the following strings:"
+{ $list
+ { $snippet "CLEAR" }
+ { $snippet "RET" }
+ { $snippet "ENTER" }
+ { $snippet "ESC" }
+ { $snippet "TAB" }
+ { $snippet "BACKSPACE" }
+ { $snippet "HOME" }
+ { $snippet "DELETE" }
+ { $snippet "END" }
+ { $snippet "F1" }
+ { $snippet "F2" }
+ { $snippet "F3" }
+ { $snippet "F4" }
+ { $snippet "F5" }
+ { $snippet "F6" }
+ { $snippet "F7" }
+ { $snippet "F8" }
+ { $snippet "LEFT" }
+ { $snippet "RIGHT" }
+ { $snippet "DOWN" }
+ { $snippet "UP" }
+ { $snippet "PAGE_UP" }
+ { $snippet "PAGE_DOWN" }
+}
+"The " { $link S+ } " modifier is only ever used with the above action keys; alphanumeric input input with the shift key is delivered without the " { $link S+ } " modifier set, instead the input itself is upper case. For example, the gesture corresponding to " { $snippet "s" } " with the Control and Shift keys pressed is presented as "
+{ $code "T{ key-down f { C+ } \"S\" }" }
+"The " { $snippet "RET" } ", " { $snippet "TAB" } " and " { $snippet "SPACE" } " keys are never delivered in their literal form (" { $snippet "\"\\n\"" } ", " { $snippet "\"\\t\"" } " or " { $snippet "\" \"" } ")." ;
+
+ARTICLE: "ui-user-input" "Free-form keyboard input"
+"Whereas keyboard gestures are intended to be used for keyboard shortcuts, certain gadgets such as text fields need to accept free-form keyboard input. This can be done by implementing a generic word:"
+{ $subsection user-input* } ;
+
+ARTICLE: "mouse-gestures" "Mouse gestures"
+"There are two types of mouse gestures indicating button clicks:"
+{ $subsection button-down }
+{ $subsection button-up }
+"When a mouse button is pressed or released, two gestures are sent. The first gesture indicates the specific button number, and if this gesture is not handled, the second has a button number set to " { $link f } ":"
+{ $code "T{ button-down f 1 }" "T{ button-down f f }" }
+"Because tuple literals fill unspecified slots with " { $link f } ", the last gesture can be written as " { $snippet "T{ button-down }" } "."
+$nl
+"Gestures to indicate mouse motion, depending on whenever a button is held down or not:"
+{ $subsection motion }
+{ $subsection drag }
+"Gestures to indicate that the mouse has crossed gadget boundaries:"
+{ $subsection mouse-enter }
+{ $subsection mouse-leave }
+"A number of global variables are set after a mouse gesture is sent. These variables can be read to obtain additional information about the gesture."
+{ $subsection hand-gadget }
+{ $subsection hand-world }
+{ $subsection hand-loc }
+{ $subsection hand-buttons }
+{ $subsection hand-clicked }
+{ $subsection hand-click-loc }
+{ $subsection hand-click# }
+"There are some utility words for working with click locations:"
+{ $subsection hand-rel }
+{ $subsection hand-click-rel }
+{ $subsection drag-loc }
+"Mouse scroll wheel gesture:"
+{ $subsection mouse-scroll }
+"Global variable set when a mouse scroll wheel gesture is sent:"
+{ $subsection scroll-direction } ;
+
+ARTICLE: "action-gestures" "Action gestures"
+"Action gestures exist to keep keyboard shortcuts for common clipboard operations consistent."
+{ $subsection cut-action }
+{ $subsection copy-action }
+{ $subsection paste-action }
+{ $subsection delete-action }
+{ $subsection select-all-action }
+"The following keyboard gestures, if not handled directly, send action gestures:"
+{ $table
+ { { $strong "Keyboard gesture" } { $strong "Action gesture" } }
+ { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "T{ cut-action }" } }
+ { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "T{ copy-action }" } }
+ { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "T{ paste-action }" } }
+ { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "T{ select-all }" } }
+}
+"Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ;
+
+ABOUT: "ui-gestures"
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs kernel math models namespaces
+sequences words strings system hashtables math.parser
+math.vectors classes.tuple classes ui.gadgets boxes
+calendar alarms symbols combinators sets columns ;
+IN: ui.gestures
+
+: set-gestures ( class hash -- ) "gestures" set-word-prop ;
+
+GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
+
+: default-gesture-handler ( gadget gesture delegate -- ? )
+ class superclasses [ "gestures" word-prop ] map assoc-stack dup
+ [ call f ] [ 2drop t ] if ;
+
+M: object handle-gesture* default-gesture-handler ;
+
+: handle-gesture ( gesture gadget -- ? )
+ tuck delegates [ >r 2dup r> handle-gesture* ] all? 2nip ;
+
+: send-gesture ( gesture gadget -- ? )
+ [ dupd handle-gesture ] each-parent nip ;
+
+: user-input ( str gadget -- )
+ over empty?
+ [ [ dupd user-input* ] each-parent ] unless
+ 2drop ;
+
+! Gesture objects
+TUPLE: motion ; C: <motion> motion
+TUPLE: drag # ; C: <drag> drag
+TUPLE: button-up mods # ; C: <button-up> button-up
+TUPLE: button-down mods # ; C: <button-down> button-down
+TUPLE: mouse-scroll ; C: <mouse-scroll> mouse-scroll
+TUPLE: mouse-enter ; C: <mouse-enter> mouse-enter
+TUPLE: mouse-leave ; C: <mouse-leave> mouse-leave
+TUPLE: lose-focus ; C: <lose-focus> lose-focus
+TUPLE: gain-focus ; C: <gain-focus> gain-focus
+
+! Higher-level actions
+TUPLE: cut-action ; C: <cut-action> cut-action
+TUPLE: copy-action ; C: <copy-action> copy-action
+TUPLE: paste-action ; C: <paste-action> paste-action
+TUPLE: delete-action ; C: <delete-action> delete-action
+TUPLE: select-all-action ; C: <select-all-action> select-all-action
+
+TUPLE: left-action ; C: <left-action> left-action
+TUPLE: right-action ; C: <right-action> right-action
+TUPLE: up-action ; C: <up-action> up-action
+TUPLE: down-action ; C: <down-action> down-action
+
+TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
+TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
+
+: generalize-gesture ( gesture -- newgesture )
+ clone f >># ;
+
+! Modifiers
+SYMBOLS: C+ A+ M+ S+ ;
+
+TUPLE: key-down mods sym ;
+
+: <key-gesture> ( mods sym action? class -- mods' sym' )
+ >r [ S+ rot remove swap ] unless r> boa ; inline
+
+: <key-down> ( mods sym action? -- key-down )
+ key-down <key-gesture> ;
+
+TUPLE: key-up mods sym ;
+
+: <key-up> ( mods sym action? -- key-up )
+ key-up <key-gesture> ;
+
+! Hand state
+
+! Note that these are only really useful inside an event
+! handler, and that the locations hand-loc and hand-click-loc
+! are in the co-ordinate system of the world which contains
+! the gadget in question.
+SYMBOL: hand-gadget
+SYMBOL: hand-world
+SYMBOL: hand-loc
+{ 0 0 } hand-loc set-global
+
+SYMBOL: hand-clicked
+SYMBOL: hand-click-loc
+SYMBOL: hand-click#
+SYMBOL: hand-last-button
+SYMBOL: hand-last-time
+0 hand-last-button set-global
+0 hand-last-time set-global
+
+SYMBOL: hand-buttons
+V{ } clone hand-buttons set-global
+
+SYMBOL: scroll-direction
+{ 0 0 } scroll-direction set-global
+
+SYMBOL: double-click-timeout
+300 double-click-timeout set-global
+
+: hand-moved? ( -- ? )
+ hand-loc get hand-click-loc get = not ;
+
+: button-gesture ( gesture -- )
+ hand-clicked get-global 2dup send-gesture [
+ >r generalize-gesture r> send-gesture drop
+ ] [
+ 2drop
+ ] if ;
+
+: drag-gesture ( -- )
+ hand-buttons get-global
+ dup empty? [ drop ] [ first <drag> button-gesture ] if ;
+
+SYMBOL: drag-timer
+
+<box> drag-timer set-global
+
+: start-drag-timer ( -- )
+ hand-buttons get-global empty? [
+ [ drag-gesture ]
+ 300 milliseconds hence
+ 100 milliseconds
+ add-alarm drag-timer get-global >box
+ ] when ;
+
+: stop-drag-timer ( -- )
+ hand-buttons get-global empty? [
+ drag-timer get-global ?box
+ [ cancel-alarm ] [ drop ] if
+ ] when ;
+
+: fire-motion ( -- )
+ hand-buttons get-global empty? [
+ T{ motion } hand-gadget get-global send-gesture drop
+ ] [
+ drag-gesture
+ ] if ;
+
+: each-gesture ( gesture seq -- )
+ [ handle-gesture drop ] with each ;
+
+: hand-gestures ( new old -- )
+ drop-prefix <reversed>
+ T{ mouse-leave } swap each-gesture
+ T{ mouse-enter } swap each-gesture ;
+
+: forget-rollover ( -- )
+ f hand-world set-global
+ hand-gadget get-global >r
+ f hand-gadget set-global
+ f r> parents hand-gestures ;
+
+: send-lose-focus ( gadget -- )
+ T{ lose-focus } swap handle-gesture drop ;
+
+: send-gain-focus ( gadget -- )
+ T{ gain-focus } swap handle-gesture drop ;
+
+: focus-child ( child gadget ? -- )
+ [
+ dup gadget-focus [
+ dup send-lose-focus
+ f swap t focus-child
+ ] when*
+ dupd set-gadget-focus [
+ send-gain-focus
+ ] when*
+ ] [
+ set-gadget-focus
+ ] if ;
+
+: modifier ( mod modifiers -- seq )
+ [ second swap bitand 0 > ] with filter
+ 0 <column> prune dup empty? [ drop f ] [ >array ] if ;
+
+: drag-loc ( -- loc )
+ hand-loc get-global hand-click-loc get-global v- ;
+
+: hand-rel ( gadget -- loc )
+ hand-loc get-global swap screen-loc v- ;
+
+: hand-click-rel ( gadget -- loc )
+ hand-click-loc get-global swap screen-loc v- ;
+
+: multi-click-timeout? ( -- ? )
+ millis hand-last-time get - double-click-timeout get <= ;
+
+: multi-click-button? ( button -- button ? )
+ dup hand-last-button get = ;
+
+: multi-click-position? ( -- ? )
+ hand-loc get hand-click-loc get v- norm-sq 100 <= ;
+
+: multi-click? ( button -- ? )
+ {
+ { [ multi-click-timeout? not ] [ f ] }
+ { [ multi-click-button? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+: update-click# ( button -- )
+ global [
+ dup multi-click? [
+ hand-click# inc
+ ] [
+ 1 hand-click# set
+ ] if
+ hand-last-button set
+ millis hand-last-time set
+ ] bind ;
+
+: update-clicked ( -- )
+ hand-gadget get-global hand-clicked set-global
+ hand-loc get-global hand-click-loc set-global ;
+
+: under-hand ( -- seq )
+ hand-gadget get-global parents <reversed> ;
+
+: move-hand ( loc world -- )
+ dup hand-world set-global
+ under-hand >r over hand-loc set-global
+ pick-up hand-gadget set-global
+ under-hand r> hand-gestures ;
+
+: send-button-down ( gesture loc world -- )
+ move-hand
+ start-drag-timer
+ dup button-down-#
+ dup update-click# hand-buttons get-global push
+ update-clicked
+ button-gesture ;
+
+: send-button-up ( gesture loc world -- )
+ move-hand
+ dup button-up-# hand-buttons get-global delete
+ stop-drag-timer
+ button-gesture ;
+
+: send-wheel ( direction loc world -- )
+ move-hand
+ scroll-direction set-global
+ T{ mouse-scroll } hand-gadget get-global send-gesture
+ drop ;
+
+: world-focus ( world -- gadget )
+ dup gadget-focus [ world-focus ] [ ] ?if ;
+
+: send-action ( world gesture -- )
+ swap world-focus send-gesture drop ;
+
+: resend-button-down ( gesture world -- )
+ hand-loc get-global swap send-button-down ;
+
+: resend-button-up ( gesture world -- )
+ hand-loc get-global swap send-button-up ;
+
+GENERIC: gesture>string ( gesture -- string/f )
+
+: modifiers>string ( modifiers -- string )
+ [ name>> ] map concat >string ;
+
+M: key-down gesture>string
+ dup key-down-mods modifiers>string
+ swap key-down-sym append ;
+
+M: button-up gesture>string
+ [
+ dup button-up-mods modifiers>string %
+ "Click Button" %
+ button-up-# [ " " % # ] when*
+ ] "" make ;
+
+M: button-down gesture>string
+ [
+ dup button-down-mods modifiers>string %
+ "Press Button" %
+ button-down-# [ " " % # ] when*
+ ] "" make ;
+
+M: left-action gesture>string drop "Swipe left" ;
+
+M: right-action gesture>string drop "Swipe right" ;
+
+M: up-action gesture>string drop "Swipe up" ;
+
+M: down-action gesture>string drop "Swipe down" ;
+
+M: zoom-in-action gesture>string drop "Zoom in" ;
+
+M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
+
+M: object gesture>string drop f ;
--- /dev/null
+Translating window system events to gestures, and delivering gestures to gadgets
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.commands help.markup help.syntax ui.gadgets words
+kernel hashtables strings classes quotations sequences
+ui.gestures ;
+IN: ui.operations
+
+: $operations ( element -- )
+ >quotation call
+ f f operations>commands
+ command-map. ;
+
+: $operation ( element -- )
+ first +keyboard+ word-prop gesture>string $snippet ;
+
+HELP: +keyboard+
+{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". The value is a gesture." } ;
+
+HELP: +primary+
+{ $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 a presentation matching the operation's predicate is clicked with the mouse." } ;
+
+HELP: operation
+{ $description "An abstraction for an operation which may be performed on a presentation."
+$nl
+"Operations have the following slots:"
+{ $list
+ { { $link operation-predicate } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
+ { { $link operation-command } " - a " { $link word } }
+ { { $link operation-translator } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
+ { { $link operation-hook } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
+ { { $link operation-listener? } " - a boolean" }
+} } ;
+
+HELP: operation-gesture
+{ $values { "operation" operation } { "gesture" "a gesture or " { $link f } } }
+{ $description "Outputs the keyboard gesture associated with the operation." } ;
+
+HELP: operations
+{ $var-description "Global variable holding a vector of " { $link operation } " instances. New operations can be added with " { $link define-operation } "." } ;
+
+HELP: object-operations
+{ $values { "obj" object } { "operations" "a sequence of " { $link operation } " instances" } }
+{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $link operation-predicate } " quotation in turn." } ;
+
+HELP: primary-operation
+{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
+{ $description "Outputs the operation which should be invoked when a presentation of " { $snippet "obj" } " is clicked." } ;
+
+HELP: secondary-operation
+{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
+{ $description "Outputs the operation which should be invoked when a " { $snippet "RET" } " is pressed while a presentation of " { $snippet "obj" } " is selected in a list." } ;
+
+HELP: define-operation
+{ $values { "pred" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "command" word } { "flags" hashtable } }
+{ $description "Defines an operation on objects matching the predicate. The hashtable can contain the following keys:"
+ { $list
+ { { $link +listener+ } " - if set to a true value, the operation will run in the listener" }
+ { { $link +description+ } " - can be set to a string description of the operation" }
+ { { $link +primary+ } " - if set to a true value, the operation will be output by " { $link primary-operation } " when applied to an object satisfying the predicate" }
+ { { $link +secondary+ } " - if set to a true value, the operation will be output by " { $link secondary-operation } " when applied to an object satisfying the predicate" }
+ { { $link +keyboard+ } " - can be set to a keyboard gesture; the guesture will be used by " { $link define-operation-map } }
+ }
+} ;
+
+HELP: define-operation-map
+{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( 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." } ;
+
+HELP: $operations
+{ $values { "element" "a sequence" } }
+{ $description "Converts the element to a quotation and calls it; the resulting quotation must have stack effect " { $snippet "( -- obj )" } ". Prints a list of operations applicable to the object, together with keyboard shortcuts." } ;
+
+HELP: $operation
+{ $values { "element" "a sequence containing a single word" } }
+{ $description "Prints the keyboard shortcut associated with the word, which must have been previously defined as an operation by a call to " { $link define-operation } "." } ;
+
+ARTICLE: "ui-operations" "Operations"
+"Operations are commands performed on presentations."
+{ $subsection operation }
+{ $subsection define-operation }
+{ $subsection primary-operation }
+{ $subsection secondary-operation }
+{ $subsection define-operation-map }
+"When documenting gadgets, operation documentation can be automatically generated:"
+{ $subsection $operations }
+{ $subsection $operation } ;
+
+ABOUT: "ui-operations"
--- /dev/null
+IN: ui.operations.tests
+USING: ui.operations ui.commands prettyprint kernel namespaces
+tools.test ui.gadgets ui.gadgets.editors parser io
+io.streams.string math help help.markup ;
+
+: my-pprint pprint ;
+
+[ drop t ] \ my-pprint [ ] [ ] f operation boa "op" set
+
+[ [ 3 my-pprint ] ] [
+ 3 "op" get operation-command command-quot
+] unit-test
+
+[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
+
+[ drop t ] \ my-pprint [ ] [ editor-string ] f operation boa
+"op" set
+
+[ "\"4\"" ] [
+ [
+ "4" <editor> [ set-editor-string ] keep
+ "op" get invoke-command
+ ] with-string-writer
+] unit-test
+
+[ ] [
+ [ { $operations \ + } print-element ] with-string-writer drop
+] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 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
+hashtables help.markup quotations assocs ;
+IN: ui.operations
+
+SYMBOL: +keyboard+
+SYMBOL: +primary+
+SYMBOL: +secondary+
+
+TUPLE: operation predicate command translator hook listener? ;
+
+: <operation> ( predicate command -- operation )
+ operation new
+ [ ] >>hook
+ [ ] >>translator
+ swap >>command
+ swap >>predicate ;
+
+PREDICATE: listener-operation < operation
+ dup operation-command listener-command?
+ swap operation-listener? or ;
+
+M: operation command-name
+ operation-command command-name ;
+
+M: operation command-description
+ operation-command command-description ;
+
+M: operation command-word operation-command command-word ;
+
+: operation-gesture ( operation -- gesture )
+ operation-command +keyboard+ word-prop ;
+
+SYMBOL: operations
+
+: object-operations ( obj -- operations )
+ operations get [ operation-predicate call ] with filter ;
+
+: find-operation ( obj quot -- command )
+ >r object-operations r> find-last nip ; inline
+
+: primary-operation ( obj -- operation )
+ [ operation-command +primary+ word-prop ] find-operation ;
+
+: secondary-operation ( obj -- operation )
+ dup
+ [ operation-command +secondary+ word-prop ] find-operation
+ [ ] [ primary-operation ] ?if ;
+
+: default-flags ( -- assoc )
+ H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
+
+: define-operation ( pred command flags -- )
+ default-flags swap assoc-union
+ dupd define-command <operation>
+ operations get push ;
+
+: modify-operation ( hook translator operation -- operation )
+ clone
+ tuck set-operation-translator
+ tuck set-operation-hook
+ t over set-operation-listener? ;
+
+: modify-operations ( operations hook translator -- operations )
+ rot [ >r 2dup r> modify-operation ] map 2nip ;
+
+: operations>commands ( object hook translator -- pairs )
+ >r >r object-operations r> r> modify-operations
+ [ [ operation-gesture ] keep ] { } map>assoc ;
+
+: define-operation-map ( class group blurb object hook translator -- )
+ operations>commands define-command-map ;
+
+: operation-quot ( target command -- quot )
+ [
+ swap literalize ,
+ dup operation-translator %
+ operation-command ,
+ ] [ ] make ;
+
+M: operation invoke-command ( target command -- )
+ [ operation-hook call ] keep operation-quot call ;
--- /dev/null
+Operations are commands which may be performed on a presentation's underlying object
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets ui.gestures help.markup help.syntax
+kernel classes strings opengl.gl models math.geometry.rect ;
+IN: ui.render
+
+HELP: gadget
+{ $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
+ { $list
+ { { $snippet "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
+ { { $snippet "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
+ { { $snippet "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
+ { { $snippet "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
+ { { $snippet "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
+ { { $snippet "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
+ { { $snippet "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
+ { { $snippet "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
+ { { $snippet "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
+ { { $snippet "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
+ { { $snippet "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
+ }
+"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
+{ $notes
+"Other classes may inherit from " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
+
+HELP: clip
+{ $var-description "The current clipping rectangle." } ;
+
+HELP: draw-gadget*
+{ $values { "gadget" gadget } }
+{ $contract "Draws the gadget by making OpenGL calls. The top-left corner of the gadget should be drawn at the location stored in the " { $link origin } " variable." }
+{ $notes "This word should not be called directly. To force a gadget to redraw, call " { $link relayout-1 } "." } ;
+
+HELP: draw-interior
+{ $values { "interior" object } { "gadget" gadget } }
+{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $link gadget-interior } " slot may be set to objects implementing this generic word." } ;
+
+HELP: draw-boundary
+{ $values { "boundary" object } { "gadget" gadget } }
+{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $link gadget-boundary } " slot may be set to objects implementing this generic word." } ;
+
+HELP: solid
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ;
+
+HELP: gradient
+{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $link gadget-orientation } " slot of the gadget." } ;
+
+HELP: polygon
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
+ { $list
+ { { $link polygon-color } " - a color specifier" }
+ { { $link polygon-points } " - a sequence of points" }
+ }
+} ;
+
+HELP: <polygon>
+{ $values { "color" "a color specifier" } { "points" "a sequence of points" } }
+{ $description "Creates a new instance of " { $link polygon } "." } ;
+
+HELP: <polygon-gadget>
+{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "gadget" "a new " { $link gadget } } }
+{ $description "Creates a gadget which is drawn as a solid filled polygon. The gadget's size is the minimum bounding box containing all the points of the polygon." } ;
+
+HELP: open-font
+{ $values { "font" "a font specifier" } { "open-font" object } }
+{ $description "Loads a font if it has not already been loaded, otherwise outputs the existing font." }
+{ $errors "Throws an error if the font does not exist." } ;
+
+HELP: string-width
+{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "w" "a positive integer" } }
+{ $description "Outputs the width of a string." } ;
+
+HELP: text-dim
+{ $values { "open-font" "a value output by " { $link open-font } } { "text" "a string or an array of strings" } { "dim" "a pair of integers" } }
+{ $description "Outputs the dimensions of a piece of text, which is either a single-line string or an array of lines." } ;
+
+HELP: draw-string
+{ $values { "font" "a font specifier" } { "string" string } { "loc" "a pair of integers" } }
+{ $description "Draws a line of text." } ;
+
+HELP: draw-text
+{ $values { "font" "a font specifier" } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
+{ $description "Draws text. Text is either a single-line string or an array of lines." } ;
+
+ARTICLE: "gadgets-polygons" "Polygon gadgets"
+"A polygon gadget renders a simple shaded polygon."
+{ $subsection <polygon-gadget> }
+"Some pre-made polygons:"
+{ $subsection arrow-up }
+{ $subsection arrow-right }
+{ $subsection arrow-down }
+{ $subsection arrow-left }
+{ $subsection close-box }
+"Polygon gadgets are rendered by the " { $link polygon } " pen protocol implementation." ;
+
+ARTICLE: "ui-paint" "Customizing gadget appearance"
+"The UI carries out the following steps when drawing a gadget:"
+{ $list
+ { "The " { $link draw-interior } " generic word is called on the value of the " { $link gadget-interior } " slot." }
+ { "The " { $link draw-gadget* } " generic word is called on the gadget." }
+ { "The gadget's visible children are drawn, determined by calling " { $link visible-children } " on the gadget." }
+ { "The " { $link draw-boundary } " generic word is called on the value of the " { $link gadget-boundary } " slot." }
+}
+"Now, each one of these steps will be covered in detail."
+{ $subsection "ui-pen-protocol" }
+{ $subsection "ui-paint-custom" } ;
+
+ARTICLE: "ui-pen-protocol" "UI pen protocol"
+"The " { $link gadget-interior } " and " { $link gadget-boundary } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:"
+{ $subsection draw-interior }
+{ $subsection draw-boundary }
+"The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing."
+$nl
+"Some other pre-defined implementations:"
+{ $subsection solid }
+{ $subsection gradient }
+{ $subsection polygon }
+"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
+
+ARTICLE: "text-rendering" "Rendering text"
+"Unlike OpenGL, Factor's FreeType binding only includes the bare essentials, and there is rarely any need to directly call words in the " { $vocab-link "freetype" } " vocabulary directly. Instead, the UI provides high-level wrappers."
+$nl
+"Font objects are never constructed directly, and instead are obtained by calling a word:"
+{ $subsection open-font }
+"Measuring text:"
+{ $subsection text-dim }
+{ $subsection text-height }
+{ $subsection text-width }
+"Rendering text:"
+{ $subsection draw-string }
+{ $subsection draw-text } ;
+
+ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
+"The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
+{ $subsection draw-gadget* }
+"Custom drawing code has access to the full OpenGL API in the " { $vocab-link "opengl" } " vocabulary."
+$nl
+"The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is not saved or restored when rendering a gadget. Instead, the origin of the gadget relative to the OpenGL context is stored in a variable:"
+{ $subsection origin }
+"Custom drawing implementations can translate co-ordinates manually, or save and restore the " { $link GL_MODELVIEW } " matrix."
+$nl
+"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
+$nl
+"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $link gadget-clipped? } " slot to " { $link t } " in the gadget's constructor."
+$nl
+"Saving the " { $link GL_MODELVIEW } " matrix and enabling/disabling flags can be done in a clean way using the combinators documented in the following section."
+{ $subsection "gl-utilities" }
+{ $subsection "text-rendering" } ;
+
+ABOUT: "ui-paint-custom"
--- /dev/null
+! Copyright (C) 2005, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays hashtables io kernel math namespaces opengl
+opengl.gl opengl.glu sequences strings io.styles vectors
+combinators math.vectors ui.gadgets colors
+math.order math.geometry.rect ;
+IN: ui.render
+
+SYMBOL: clip
+
+SYMBOL: viewport-translation
+
+: flip-rect ( rect -- loc dim )
+ rect-bounds [
+ >r { 1 -1 } v* r> { 0 -1 } v* v+
+ viewport-translation get v+
+ ] keep ;
+
+: do-clip ( -- ) clip get flip-rect gl-set-clip ;
+
+: init-clip ( clip-rect rect -- )
+ GL_SCISSOR_TEST glEnable
+ [ rect-intersect ] keep
+ rect-dim dup { 0 1 } v* viewport-translation set
+ { 0 0 } over gl-viewport
+ 0 swap first2 0 gluOrtho2D
+ clip set
+ do-clip ;
+
+: init-gl ( clip-rect rect -- )
+ GL_SMOOTH glShadeModel
+ GL_BLEND glEnable
+ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
+ init-matrices
+ init-clip
+ ! white gl-clear is broken w.r.t window resizing
+ ! Linux/PPC Radeon 9200
+ white set-color
+ clip get rect-extent gl-fill-rect ;
+
+GENERIC: draw-gadget* ( gadget -- )
+
+M: gadget draw-gadget* drop ;
+
+GENERIC: draw-interior ( gadget interior -- )
+
+GENERIC: draw-boundary ( gadget boundary -- )
+
+SYMBOL: origin
+
+{ 0 0 } origin set-global
+
+: visible-children ( gadget -- seq )
+ clip get origin get vneg offset-rect swap children-on ;
+
+: translate ( rect/point -- ) rect-loc origin [ v+ ] change ;
+
+DEFER: draw-gadget
+
+: (draw-gadget) ( gadget -- )
+ [
+ dup translate
+ dup dup gadget-interior draw-interior
+ dup draw-gadget*
+ dup visible-children [ draw-gadget ] each
+ dup gadget-boundary draw-boundary
+ ] with-scope ;
+
+: >absolute ( rect -- rect )
+ origin get offset-rect ;
+
+: change-clip ( gadget -- )
+ >absolute clip [ rect-intersect ] change ;
+
+: with-clipping ( gadget quot -- )
+ clip get >r
+ over change-clip do-clip call
+ r> clip set do-clip ; inline
+
+: draw-gadget ( gadget -- )
+ {
+ { [ dup gadget-visible? not ] [ drop ] }
+ { [ dup gadget-clipped? not ] [ (draw-gadget) ] }
+ [ [ (draw-gadget) ] with-clipping ]
+ } cond ;
+
+! Pen paint properties
+M: f draw-interior 2drop ;
+M: f draw-boundary 2drop ;
+
+! Solid fill/border
+TUPLE: solid color ;
+
+C: <solid> solid
+
+! Solid pen
+: (solid) ( gadget paint -- loc dim )
+ solid-color set-color rect-dim >r origin get dup r> v+ ;
+
+M: solid draw-interior (solid) gl-fill-rect ;
+
+M: solid draw-boundary (solid) gl-rect ;
+
+! Gradient pen
+TUPLE: gradient colors ;
+
+C: <gradient> gradient
+
+M: gradient draw-interior
+ origin get [
+ over gadget-orientation
+ swap gradient-colors
+ rot rect-dim
+ gl-gradient
+ ] with-translation ;
+
+! Polygon pen
+TUPLE: polygon color points ;
+
+C: <polygon> polygon
+
+: draw-polygon ( polygon quot -- )
+ origin get [
+ >r dup polygon-color set-color polygon-points r> call
+ ] with-translation ; inline
+
+M: polygon draw-boundary
+ [ gl-poly ] draw-polygon drop ;
+
+M: polygon draw-interior
+ [ gl-fill-poly ] draw-polygon drop ;
+
+: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
+: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
+: arrow-down { { 0 0 } { 6 0 } { 3 6 } } ;
+: arrow-left { { 0 3 } { 6 0 } { 6 6 } } ;
+: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ;
+
+: <polygon-gadget> ( color points -- gadget )
+ dup max-dim
+ >r <polygon> <gadget> r> over set-rect-dim
+ [ set-gadget-interior ] keep ;
+
+! Font rendering
+SYMBOL: font-renderer
+
+HOOK: open-font font-renderer ( font -- open-font )
+
+HOOK: string-width font-renderer ( open-font string -- w )
+
+HOOK: string-height font-renderer ( open-font string -- h )
+
+HOOK: draw-string font-renderer ( font string loc -- )
+
+HOOK: x>offset font-renderer ( x open-font string -- n )
+
+HOOK: free-fonts font-renderer ( world -- )
+
+: text-height ( open-font text -- n )
+ dup string? [
+ string-height
+ ] [
+ [ string-height ] with map sum
+ ] if ;
+
+: text-width ( open-font text -- n )
+ dup string? [
+ string-width
+ ] [
+ 0 -rot [ string-width max ] with each
+ ] if ;
+
+: text-dim ( open-font text -- dim )
+ [ text-width ] 2keep text-height 2array ;
+
+: draw-text ( font text loc -- )
+ over string? [
+ draw-string
+ ] [
+ [
+ [
+ 2dup { 0 0 } draw-string
+ >r open-font r> string-height
+ 0.0 swap 0.0 glTranslated
+ ] with each
+ ] with-translation
+ ] if ;
--- /dev/null
+Support for rendering gadgets via OpenGL
--- /dev/null
+Factor's graphical user interface framework
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: ui.tools.browser.tests
+USING: tools.test tools.test.ui ui.tools.browser ;
+
+\ <browser-gadget> must-infer
+[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 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 ;
+IN: ui.tools.browser
+
+TUPLE: browser-gadget < track pane history ;
+
+: show-help ( link help -- )
+ dup history>> add-history
+ >r >link r> history>> set-model ;
+
+: <help-pane> ( browser-gadget -- gadget )
+ history>> [ [ help ] curry try ] <pane-control> ;
+
+: init-history ( browser-gadget -- )
+ "handbook" >link <history> >>history drop ;
+
+: <browser-gadget> ( -- gadget )
+ { 0 1 } browser-gadget new-track
+ dup init-history
+ dup <toolbar> f track-add
+ dup <help-pane> >>pane
+ dup pane>> <scroller> 1 track-add ;
+
+M: browser-gadget call-tool* show-help ;
+
+M: browser-gadget tool-scroller
+ pane>> find-scroller ;
+
+M: browser-gadget graft*
+ [ add-definition-observer ] [ call-next-method ] bi ;
+
+M: browser-gadget ungraft*
+ [ call-next-method ] [ remove-definition-observer ] bi ;
+
+: showing-definition? ( defspec assoc -- ? )
+ [ key? ] 2keep
+ [ >r dup word-link? [ link-name ] when r> key? ] 2keep
+ >r dup vocab-link? [ vocab ] when r> key?
+ or or ;
+
+M: browser-gadget definitions-changed ( assoc browser -- )
+ history>>
+ dup model-value rot showing-definition?
+ [ notify-connections ] [ drop ] if ;
+
+: help-action ( browser-gadget -- link )
+ history>> model-value >link ;
+
+: com-follow ( link -- ) browser-gadget call-tool ;
+
+: com-back ( browser -- ) history>> go-back ;
+
+: com-forward ( browser -- ) history>> go-forward ;
+
+: com-documentation ( browser -- ) "handbook" swap show-help ;
+
+: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
+
+: browser-help ( -- ) "ui-browser" help-window ;
+
+\ browser-help H{ { +nullary+ t } } define-command
+
+browser-gadget "toolbar" f {
+ { T{ key-down f { A+ } "b" } com-back }
+ { T{ key-down f { A+ } "f" } com-forward }
+ { T{ key-down f { A+ } "h" } com-documentation }
+ { T{ key-down f { A+ } "v" } com-vocabularies }
+ { T{ key-down f f "F1" } browser-help }
+} define-command-map
+
+browser-gadget "multi-touch" f {
+ { T{ left-action } com-back }
+ { T{ right-action } com-forward }
+} define-command-map
--- /dev/null
+Graphical help browser
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: ui.gadgets help.markup help.syntax kernel quotations
+continuations debugger ui ;
+IN: ui.tools.debugger
+
+HELP: <debugger>
+{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "gadget" "a new " { $link gadget } } }
+{ $description
+ "Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
+} ;
+
+{ <debugger> debugger-window ui-try } related-words
+
+HELP: debugger-window
+{ $values { "error" "an error" } }
+{ $description "Opens a window with a description of the error." } ;
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
+ ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
+ ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
+ ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
+ ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
+ models namespaces sequences sequences words continuations
+ debugger prettyprint ui.tools.traceback help editors ;
+
+IN: ui.tools.debugger
+
+: <restart-list> ( restarts restart-hook -- gadget )
+ [ restart-name ] rot <model> <list> ;
+
+TUPLE: debugger < track restarts ;
+
+: <debugger-display> ( restart-list error -- gadget )
+ <filled-pile>
+ <pane>
+ swapd tuck [ print-error ] with-pane
+ add-gadget
+
+ swap add-gadget ;
+
+: <debugger> ( error restarts restart-hook -- gadget )
+ { 0 1 } debugger new-track
+ dup <toolbar> f track-add
+ -rot <restart-list> >>restarts
+ dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
+
+M: debugger focusable-child* debugger-restarts ;
+
+: debugger-window ( error -- )
+ #! No restarts for the debugger window
+ f [ drop ] <debugger> "Error" open-window ;
+
+[ debugger-window ] ui-error-hook set-global
+
+M: world-error error.
+ "An error occurred while drawing the world " write
+ dup world>> pprint-short "." print
+ "This world has been deactivated to prevent cascading errors." print
+ error>> error. ;
+
+debugger "gestures" f {
+ { T{ button-down } request-focus }
+} define-command-map
+
+: com-traceback ( -- ) error-continuation get traceback-window ;
+
+\ com-traceback H{ { +nullary+ t } } define-command
+
+\ :help H{ { +nullary+ t } { +listener+ t } } define-command
+
+\ :edit H{ { +nullary+ t } { +listener+ t } } define-command
+
+debugger "toolbar" f {
+ { T{ key-down f f "s" } com-traceback }
+ { T{ key-down f f "h" } :help }
+ { T{ key-down f f "e" } :edit }
+} define-command-map
--- /dev/null
+Graphical error display
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax ;
+IN: ui.tools.deploy
+
+HELP: deploy-tool
+{ $values { "vocab" "a vocabulary specifier" } }
+{ $description "Opens the graphical deployment tool for the specified vocabulary." }
+{ $examples { $code "\"tetris\" deploy-tool" } } ;
+
+ARTICLE: "ui.tools.deploy" "Application deployment UI tool"
+"The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically."
+$nl
+"To start the tool, pass a vocabulary name to a word:"
+{ $subsection deploy-tool }
+"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu."
+{ $see-also "tools.deploy" } ;
+
+ABOUT: "ui.tools.deploy"
--- /dev/null
+! Copyright (C) 2007 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
+ namespaces 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 ;
+
+IN: ui.tools.deploy
+
+TUPLE: deploy-gadget < pack vocab settings ;
+
+: bundle-name ( parent -- parent )
+ deploy-name get <field>
+ "Executable name:" label-on-left add-gadget ;
+
+: deploy-ui ( parent -- parent )
+ deploy-ui? get
+ "Include user interface framework" <checkbox> add-gadget ;
+
+: exit-when-windows-closed ( parent -- parent )
+ "stop-after-last-window?" get
+ "Exit when last UI window closed" <checkbox> add-gadget ;
+
+: io-settings ( parent -- parent )
+ "Input/output support:" <label> add-gadget
+ deploy-io get deploy-io-options <radio-buttons> add-gadget ;
+
+: reflection-settings ( parent -- parent )
+ "Reflection support:" <label> add-gadget
+ deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
+
+: advanced-settings ( parent -- parent )
+ "Advanced:" <label> add-gadget
+ deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
+ deploy-math? get "Rational and complex number support" <checkbox> add-gadget
+ deploy-threads? get "Threading support" <checkbox> add-gadget
+ deploy-random? get "Random number generator support" <checkbox> add-gadget
+ deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
+ deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
+ deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
+
+: deploy-settings-theme ( gadget -- gadget )
+ { 10 10 } >>gap
+ 1 >>fill ;
+
+: <deploy-settings> ( vocab -- control )
+ default-config [ <model> ] assoc-map
+ [
+ <pile>
+ bundle-name
+ deploy-ui
+ os macosx? [ exit-when-windows-closed ] when
+ io-settings
+ reflection-settings
+ advanced-settings
+
+ deploy-settings-theme
+ namespace <mapping> over set-gadget-model
+ ]
+ bind ;
+
+: find-deploy-gadget ( gadget -- deploy-gadget )
+ [ deploy-gadget? ] find-parent ;
+
+: find-deploy-vocab ( gadget -- vocab )
+ find-deploy-gadget deploy-gadget-vocab ;
+
+: find-deploy-config ( gadget -- config )
+ find-deploy-vocab deploy-config ;
+
+: find-deploy-settings ( gadget -- settings )
+ find-deploy-gadget deploy-gadget-settings ;
+
+: com-revert ( gadget -- )
+ dup find-deploy-config
+ swap find-deploy-settings set-control-value ;
+
+: com-save ( gadget -- )
+ dup find-deploy-settings control-value
+ swap find-deploy-vocab set-deploy-config ;
+
+: com-deploy ( gadget -- )
+ dup com-save
+ dup find-deploy-vocab [ deploy ] curry call-listener
+ close-window ;
+
+: com-help ( -- )
+ "ui.tools.deploy" help-window ;
+
+\ com-help H{
+ { +nullary+ t }
+} define-command
+
+: com-close ( gadget -- )
+ close-window ;
+
+deploy-gadget "toolbar" f {
+ { f com-close }
+ { f com-help }
+ { f com-revert }
+ { f com-save }
+ { T{ key-down f f "RET" } com-deploy }
+} define-command-map
+
+: <deploy-gadget> ( vocab -- gadget )
+ deploy-gadget new-gadget
+ over >>vocab
+ { 0 1 } >>orientation
+ swap <deploy-settings> >>settings
+ dup settings>> add-gadget
+ dup <toolbar> { 10 10 } >>gap add-gadget
+ deploy-settings-theme
+ dup com-revert ;
+
+: deploy-tool ( vocab -- )
+ vocab-name dup <deploy-gadget> 10 <border>
+ "Deploying \"" rot "\"" 3append open-window ;
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2008 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 ;
+IN: ui.tools.inspector
+
+TUPLE: inspector-gadget < track object pane ;
+
+: refresh ( inspector -- )
+ [ object>> ] [ pane>> ] bi [
+ +editable+ on
+ +number-rows+ on
+ describe
+ ] with-pane ;
+
+: <inspector-gadget> ( -- gadget )
+ { 0 1 } inspector-gadget new-track
+ dup <toolbar> f track-add
+ <pane> >>pane
+ dup pane>> <scroller> 1 track-add ;
+
+: inspect-object ( obj mirror keys inspector -- )
+ 2nip swap >>object refresh ;
+
+\ &push H{ { +nullary+ t } { +listener+ t } } define-command
+
+\ &back H{ { +nullary+ t } { +listener+ t } } define-command
+
+\ &globals H{ { +nullary+ t } { +listener+ t } } define-command
+
+: inspector-help ( -- ) "ui-inspector" help-window ;
+
+\ inspector-help H{ { +nullary+ t } } define-command
+
+inspector-gadget "toolbar" f {
+ { T{ update-object } refresh }
+ { f &push }
+ { f &back }
+ { f &globals }
+ { T{ key-down f f "F1" } inspector-help }
+} define-command-map
+
+inspector-gadget "multi-touch" f {
+ { T{ left-action } &back }
+} define-command-map
+
+M: inspector-gadget tool-scroller
+ inspector-gadget-pane find-scroller ;
--- /dev/null
+Graphical object viewer and editor
--- /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
+
+[ ] [ 1000 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 sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ ] [ 100 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 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 ;
+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 )
+ editor-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 [
+ [ gadget-model T{ one-word-elt } elt-string ] keep
+ interactor-use assoc-stack
+ ] [
+ 2drop f
+ ] if ;
+
+M: interactor model-changed
+ 2dup help>> eq? [
+ swap model-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 ] [ interactor-history adjoin ] if ;
+
+: interactor-continue ( obj interactor -- )
+ mailbox>> mailbox-put ;
+
+: clear-input ( interactor -- ) gadget-model clear-doc ;
+
+: interactor-finish ( interactor -- )
+ #! The spawn is a kludge to make it infer. Stupid.
+ [ editor-string ] keep
+ [ interactor-input. ] 2keep
+ [ add-interactor-history ] keep
+ [ clear-input ] curry "Clearing input" spawn drop ;
+
+: 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 ""
+ ] [
+ >r interactor-read dup [ "\n" join ] when r> 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 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 ;
+
+M: interactor pref-dim*
+ [ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
+ vmax ;
+
+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
--- /dev/null
+USING: continuations documents ui.tools.interactor
+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 ;
+IN: ui.tools.listener.tests
+
+[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
+
+[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
+
+[ ] [ <listener-gadget> "listener" set ] unit-test
+
+"listener" get [
+ [ "dup" ] [
+ \ dup word-completion-string
+ ] unit-test
+
+ [ "equal?" ]
+ [ \ array \ equal? method word-completion-string ] unit-test
+
+ <pane> <interactor> "i" set
+
+ [ t ] [ "i" get interactor? ] unit-test
+
+ [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
+
+ [ ] [
+ "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
+ ] unit-test
+
+ [ t ] [
+ "i" get gadget-model doc-end
+ "i" get editor-caret* =
+ ] unit-test
+
+ ! Race condition discovered by SimonRC
+ [ ] [
+ [
+ "listener" get input>>
+ [ stream-read-quot drop ]
+ [ stream-read-quot drop ] bi
+ ] "OH, HAI" spawn drop
+ ] unit-test
+
+ [ ] [ "listener" get clear-output ] unit-test
+
+ [ ] [ "listener" get restart-listener ] unit-test
+
+ [ ] [ 1000 sleep ] unit-test
+
+ [ ] [ "listener" get com-end ] unit-test
+] with-grafted-gadget
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: inspector ui.tools.interactor ui.tools.inspector
+ui.tools.workspace help.markup io io.styles
+kernel models namespaces parser quotations sequences ui.commands
+ui.gadgets ui.gadgets.editors ui.gadgets.labelled
+ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
+ui.gadgets.tracks ui.gestures ui.operations vocabs words
+prettyprint listener debugger threads boxes concurrency.flags
+math arrays generic accessors combinators assocs ;
+IN: ui.tools.listener
+
+TUPLE: listener-gadget < track input output stack ;
+
+: listener-output, ( listener -- listener )
+ <scrolling-pane> >>output
+ dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
+
+: listener-streams ( listener -- input output )
+ [ input>> ] [ output>> <pane-stream> ] bi ;
+
+: <listener-input> ( listener -- gadget )
+ output>> <pane-stream> <interactor> ;
+
+: listener-input, ( listener -- listener )
+ dup <listener-input> >>input
+ dup input>>
+ { 0 100 } <limited-scroller>
+ "Input" <labelled-gadget>
+ f track-add ;
+
+: welcome. ( -- )
+ "If this is your first time with Factor, please read the " print
+ "handbook" ($link) "." print nl ;
+
+M: listener-gadget focusable-child*
+ input>> ;
+
+M: listener-gadget call-tool* ( input listener -- )
+ >r string>> r> input>> set-editor-string ;
+
+M: listener-gadget tool-scroller
+ output>> find-scroller ;
+
+: wait-for-listener ( listener -- )
+ #! Wait for the listener to start.
+ input>> flag>> wait-for-flag ;
+
+: workspace-busy? ( workspace -- ? )
+ listener>> input>> interactor-busy? ;
+
+: listener-input ( string -- )
+ get-workspace listener>> input>> set-editor-string ;
+
+: (call-listener) ( quot listener -- )
+ input>> interactor-call ;
+
+: call-listener ( quot -- )
+ [ workspace-busy? not ] get-workspace* listener>>
+ [ dup wait-for-listener (call-listener) ] 2curry
+ "Listener call" spawn drop ;
+
+M: listener-command invoke-command ( target command -- )
+ command-quot call-listener ;
+
+M: listener-operation invoke-command ( target command -- )
+ [ operation-hook call ] keep operation-quot call-listener ;
+
+: eval-listener ( string -- )
+ get-workspace
+ listener>> input>> [ set-editor-string ] keep
+ evaluate-input ;
+
+: listener-run-files ( seq -- )
+ dup empty? [
+ drop
+ ] [
+ [ [ run-file ] each ] curry call-listener
+ ] if ;
+
+: com-end ( listener -- )
+ input>> interactor-eof ;
+
+: clear-output ( listener -- )
+ output>> pane-clear ;
+
+\ clear-output H{ { +listener+ t } } define-command
+
+: 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>> [
+ 2dup assoc-stack pick = [ 2drop ] [
+ >r vocabulary>> vocab-words r> push
+ ] if
+ ] [ 2drop ] if ;
+
+: insert-word ( word -- )
+ get-workspace workspace-listener input>>
+ [ >r word-completion-string r> user-input ]
+ [ interactor-use use-if-necessary ]
+ 2bi ;
+
+: quot-action ( interactor -- lines )
+ dup control-value
+ dup "\n" join pick add-interactor-history
+ swap select-all ;
+
+TUPLE: stack-display < track ;
+
+: <stack-display> ( workspace -- gadget )
+ listener>>
+ { 0 1 } stack-display new-track
+ over <toolbar> f track-add
+ swap
+ stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
+ 1 track-add ;
+
+M: stack-display tool-scroller
+ find-workspace workspace-listener tool-scroller ;
+
+: ui-listener-hook ( listener -- )
+ >r datastack r> listener-gadget-stack set-model ;
+
+: ui-error-hook ( error listener -- )
+ find-workspace debugger-popup ;
+
+: ui-inspector-hook ( obj listener -- )
+ find-workspace inspector-gadget
+ swap show-tool inspect-object ;
+
+: listener-thread ( listener -- )
+ dup listener-streams [
+ [ [ ui-listener-hook ] curry listener-hook set ]
+ [ [ ui-error-hook ] curry error-hook set ]
+ [ [ ui-inspector-hook ] curry inspector-hook set ] tri
+ welcome.
+ listener
+ ] with-streams* ;
+
+: start-listener-thread ( listener -- )
+ [
+ [ input>> register-self ] [ listener-thread ] bi
+ ] curry "Listener" spawn drop ;
+
+: restart-listener ( listener -- )
+ #! Returns when listener is ready to receive input.
+ {
+ [ com-end ]
+ [ clear-output ]
+ [ input>> clear-input ]
+ [ start-listener-thread ]
+ [ wait-for-listener ]
+ } cleave ;
+
+: init-listener ( listener -- )
+ f <model> swap set-listener-gadget-stack ;
+
+: <listener-gadget> ( -- gadget )
+ { 0 1 } listener-gadget new-track
+ dup init-listener
+ listener-output,
+ listener-input, ;
+
+: listener-help ( -- ) "ui-listener" help-window ;
+
+\ listener-help H{ { +nullary+ t } } define-command
+
+listener-gadget "toolbar" f {
+ { f restart-listener }
+ { T{ key-down f f "CLEAR" } clear-output }
+ { T{ key-down f { C+ } "CLEAR" } clear-stack }
+ { T{ key-down f { C+ } "d" } com-end }
+ { T{ key-down f f "F1" } listener-help }
+} define-command-map
+
+M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
+ 3dup drop swap find-workspace workspace-page handle-gesture
+ [ default-gesture-handler ] [ 3drop f ] if ;
+
+M: listener-gadget graft*
+ [ call-next-method ] [ restart-listener ] bi ;
+
+M: listener-gadget ungraft*
+ [ com-end ] [ call-next-method ] bi ;
--- /dev/null
+Graphical code evaluator
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2006, 2007 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 inference summary inspector io.files 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 ;
+IN: ui.tools.operations
+
+V{ } clone operations set-global
+
+! Objects
+[ drop t ] \ inspect H{
+ { +primary+ t }
+ { +listener+ t }
+} define-operation
+
+: com-prettyprint ( obj -- ) . ;
+
+[ drop t ] \ com-prettyprint H{
+ { +listener+ t }
+} define-operation
+
+: com-push ( obj -- obj ) ;
+
+[ drop t ] \ com-push H{
+ { +listener+ t }
+} define-operation
+
+: com-unparse ( obj -- ) unparse listener-input ;
+
+[ drop t ] \ com-unparse H{ } define-operation
+
+! Input
+
+: com-input ( obj -- ) string>> listener-input ;
+
+[ input? ] \ com-input H{
+ { +primary+ t }
+ { +secondary+ t }
+} define-operation
+
+! Restart
+[ restart? ] \ restart H{
+ { +primary+ t }
+ { +secondary+ t }
+ { +listener+ t }
+} define-operation
+
+! Continuation
+[ continuation? ] \ traceback-window H{
+ { +primary+ t }
+ { +secondary+ t }
+} define-operation
+
+! Pathnames
+: edit-file ( pathname -- ) edit ;
+
+[ pathname? ] \ edit-file H{
+ { +keyboard+ T{ key-down f { C+ } "E" } }
+ { +primary+ t }
+ { +secondary+ t }
+ { +listener+ t }
+} define-operation
+
+UNION: definition word method-spec link vocab vocab-link ;
+
+[ definition? ] \ edit H{
+ { +keyboard+ T{ key-down f { C+ } "E" } }
+ { +listener+ t }
+} define-operation
+
+: com-forget ( defspec -- )
+ [ forget ] with-compilation-unit ;
+
+[ definition? ] \ com-forget H{ } define-operation
+
+! Words
+[ word? ] \ insert-word H{
+ { +secondary+ t }
+} define-operation
+
+[ topic? ] \ com-follow H{
+ { +keyboard+ T{ key-down f { C+ } "H" } }
+ { +primary+ t }
+} define-operation
+
+: com-usage ( word -- )
+ get-workspace swap show-word-usage ;
+
+[ word? ] \ com-usage H{
+ { +keyboard+ T{ key-down f { C+ } "U" } }
+} define-operation
+
+[ word? ] \ fix H{
+ { +keyboard+ T{ key-down f { C+ } "F" } }
+ { +listener+ t }
+} define-operation
+
+[ word? ] \ watch H{ } define-operation
+
+[ word? ] \ breakpoint H{ } define-operation
+
+GENERIC: com-stack-effect ( obj -- )
+
+M: quotation com-stack-effect infer. ;
+
+M: word com-stack-effect def>> com-stack-effect ;
+
+[ word? ] \ com-stack-effect H{
+ { +listener+ t }
+} define-operation
+
+! Vocabularies
+: com-vocab-words ( vocab -- )
+ get-workspace swap show-vocab-words ;
+
+[ vocab? ] \ com-vocab-words H{
+ { +secondary+ t }
+ { +keyboard+ T{ key-down f { C+ } "B" } }
+} define-operation
+
+: com-enter-in ( vocab -- ) vocab-name set-in ;
+
+[ vocab? ] \ com-enter-in H{
+ { +keyboard+ T{ key-down f { C+ } "I" } }
+ { +listener+ t }
+} define-operation
+
+: com-use-vocab ( vocab -- ) vocab-name use+ ;
+
+[ vocab-spec? ] \ com-use-vocab H{
+ { +secondary+ t }
+ { +listener+ t }
+} 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
+
+[ vocab-spec? ] \ deploy-tool H{ } define-operation
+
+! Quotations
+[ quotation? ] \ com-stack-effect H{
+ { +keyboard+ T{ key-down f { C+ } "i" } }
+ { +listener+ t }
+} define-operation
+
+[ quotation? ] \ walk H{
+ { +keyboard+ T{ key-down f { C+ } "w" } }
+ { +listener+ t }
+} define-operation
+
+[ quotation? ] \ time H{
+ { +keyboard+ T{ key-down f { C+ } "t" } }
+ { +listener+ t }
+} define-operation
+
+: com-show-profile ( workspace -- )
+ profiler-gadget call-tool ;
+
+: com-profile ( quot -- ) profile f com-show-profile ;
+
+[ quotation? ] \ com-profile H{
+ { +keyboard+ T{ key-down f { C+ } "r" } }
+ { +listener+ t }
+} define-operation
+
+! Profiler presentations
+[ dup usage-profile? swap vocab-profile? or ]
+\ com-show-profile H{ { +primary+ t } } define-operation
+
+! Operations -> commands
+source-editor
+"word"
+"These commands operate on the Factor word named by the token at the caret position."
+\ selected-word
+[ selected-word ]
+[ dup search [ ] [ no-word ] ?if ]
+define-operation-map
+
+interactor
+"quotation"
+"These commands operate on the entire contents of the input area."
+[ ]
+[ quot-action ]
+[ [ parse-lines ] with-compilation-unit ]
+define-operation-map
--- /dev/null
+Standard presentation operations
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2007 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 ;
+IN: ui.tools.profiler
+
+TUPLE: profiler-gadget < track pane ;
+
+: <profiler-gadget> ( -- gadget )
+ { 0 1 } profiler-gadget new-track
+ dup <toolbar> f track-add
+ <pane> >>pane
+ dup pane>> <scroller> 1 track-add ;
+
+: with-profiler-pane ( gadget quot -- )
+ >r profiler-gadget-pane r> with-pane ;
+
+: com-full-profile ( gadget -- )
+ [ profile. ] with-profiler-pane ;
+
+: com-vocabs-profile ( gadget -- )
+ [ vocabs-profile. ] with-profiler-pane ;
+
+: com-method-profile ( gadget -- )
+ [ method-profile. ] with-profiler-pane ;
+
+: profiler-help ( -- ) "ui-profiler" help-window ;
+
+\ 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
+ usage-profile-word [ usage-profile. ] curry ;
+
+M: vocab-profile profiler-presentation
+ vocab-profile-vocab [ vocab-profile. ] curry ;
+
+M: f profiler-presentation
+ drop [ vocabs-profile. ] ;
+
+M: profiler-gadget call-tool* ( obj gadget -- )
+ swap profiler-presentation with-profiler-pane ;
--- /dev/null
+Graphical call profiler
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: assocs ui.tools.search help.topics io.files io.styles
+kernel namespaces sequences source-files threads
+tools.test ui.gadgets ui.gestures vocabs
+vocabs.loader words tools.test.ui debugger ;
+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 sleep
+ live-search-list control-value
+ ] with-grafted-gadget ;
+
+: test-live-search ( gadget quot -- ? )
+ >r update-live-search dup assert-non-empty r> 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 live-search-field set-control-value
+ 300 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 ui.tools.interactor ui.tools.listener
+ui.tools.workspace help help.topics io.files io.styles kernel
+models models.delay models.filter namespaces prettyprint
+quotations sequences sorting source-files definitions strings
+tools.completion tools.crossref classes.tuple ui.commands
+ui.gadgets ui.gadgets.editors ui.gadgets.lists
+ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
+vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
+;
+IN: ui.tools.search
+
+TUPLE: live-search < track field list ;
+
+: search-value ( live-search -- value )
+ live-search-list list-value ;
+
+: search-gesture ( gesture live-search -- operation/f )
+ search-value object-operations
+ [ operation-gesture = ] with find nip ;
+
+M: live-search handle-gesture* ( gadget gesture delegate -- ? )
+ drop over search-gesture dup [
+ over find-workspace hide-popup
+ >r search-value r> invoke-command f
+ ] [
+ 2drop t
+ ] if ;
+
+: find-live-search ( gadget -- search )
+ [ [ live-search? ] is? ] find-parent ;
+
+: find-search-list ( gadget -- list )
+ find-live-search 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 -- live-search filter )
+ >r dup field>> model>> ! live-search model :: producer
+ ui-running? [ 1/5 seconds <delay> ] when
+ [ "\n" join ] r> append <filter> ;
+
+: <search-list> ( live-search seq limited? presenter -- live-search list )
+ >r
+ [ limited-completions ] [ completions ] ? curry
+ <search-model>
+ >r [ find-workspace hide-popup ] r> r>
+ swap <list> ;
+
+: <live-search> ( string seq limited? presenter -- gadget )
+ { 0 1 } live-search new-track
+ <search-field> >>field
+ dup field>> f track-add
+ -roll <search-list> >>list
+ dup list>> <scroller> 1 track-add
+
+ swap
+ over field>> set-editor-string
+ dup field>> end-of-document ;
+
+M: live-search focusable-child* live-search-field ;
+
+M: live-search pref-dim* drop { 400 200 } ;
+
+: current-word ( workspace -- string )
+ workspace-listener listener-gadget-input selected-word ;
+
+: definition-candidates ( words -- candidates )
+ [ dup synopsis >lower ] { } map>assoc sort-values ;
+
+: <definition-search> ( string words limited? -- gadget )
+ >r definition-candidates r> [ synopsis ] <live-search> ;
+
+: word-candidates ( words -- candidates )
+ [ dup name>> >lower ] { } map>assoc ;
+
+: <word-search> ( string words limited? -- gadget )
+ >r word-candidates r> [ synopsis ] <live-search> ;
+
+: com-words ( workspace -- )
+ dup current-word all-words t <word-search>
+ "Word search" show-titled-popup ;
+
+: show-vocab-words ( workspace vocab -- )
+ "" over words natural-sort f <word-search>
+ "Words in " rot vocab-name append show-titled-popup ;
+
+: show-word-usage ( workspace word -- )
+ "" over smart-usage f <definition-search>
+ "Words and methods using " rot name>> append
+ 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 [ pathname-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 -- )
+ "" over vocab-files <source-file-search>
+ "Source files in " rot vocab-name append 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 [ input-string ] <live-search> ;
+
+: listener-history ( listener -- seq )
+ listener-gadget-input interactor-history <reversed> ;
+
+: com-history ( workspace -- )
+ "" over workspace-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
--- /dev/null
+Graphical developer tools
--- /dev/null
+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 ;
+IN: ui.tools
+
+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
+"When you move the mouse over a presentation, it is highlighted with a rectangular border and a short summary of the object being presented is shown in the status bar (the summary is produced using the " { $link summary } " word)."
+$nl
+"Clicking a presentation with the left mouse button invokes a default operation, which usually views the object in some way. For example, clicking a presentation of a word jumps to the word definition in the " { $link "ui-browser" } "."
+$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 } "), and a stack display kept up to date using a " { $link listener-hook } "." ;
+
+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 } "." ;
+
+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" } ;
+
+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."
+$nl
+"First, a standard Mac-style menu bar is provided, which offers the bare minimum of what you would expect from a Mac OS X application."
+$nl
+"Dropping a source file onto the Factor icon in the dock runs the source file in the listener."
+$nl
+"If you install " { $strong "Factor.app" } " in your " { $strong "Applications" } " folder, then other applications will be able to call Factor via the System Services feature. For example, you can select some text in " { $strong "TextEdit.app" } ", then invoke the " { $strong "TextEdit->Services->Factor->Evaluate Selection" } " menu item, which will replace the selected text with the result of evaluating it in Factor."
+
+;
+
+ARTICLE: "ui-tool-tutorial" "UI tool tutorial"
+"The following is an example of a typical session with the UI which should give you a taste of its power:"
+{ $list
+ { "You decide to refactor some code, and move a few words from a source file you have already loaded, into a new source file." }
+ { "You press " { $operation edit } " in the listener, which displays a gadget where you can type part of a loaded file's name, and then press " { $snippet "RET" } " when the correct completion is highlighted. This opens the file in your editor." }
+ { "You refactor your words, move them to a new source file, and load the new file using " { $link run-file } "." }
+ { "Interactively testing the new code reveals a problem with one particular code snippet, so you enter it in the listener's input area, and press " { $operation walk } " to invoke the single stepper." }
+ { "Single stepping through the code makes the problem obvious, so you right-click on a presentation of the broken word in the stepper, and choose " { $strong "Edit" } " from the menu." }
+ { "After fixing the problem in the source editor, you right click on the word in the stepper and invoke " { $strong "Reload" } " from the menu." }
+} ;
+
+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"
+{ $command-map workspace "tool-switching" }
+{ $command-map workspace "scrolling" }
+{ $command-map workspace "workflow" }
+{ $command-map workspace "multi-touch" }
+{ $heading "Implementation" }
+"Workspaces are instances of " { $link workspace } "." ;
+
+ARTICLE: "ui-tools" "UI development tools"
+"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
+$nl
+"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
+{ $subsection "ui-tool-tutorial" }
+{ $subsection "ui-workspace-keys" }
+{ $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:"
+{ $subsection "ui-cocoa" } ;
+
+ABOUT: "ui-tools"
--- /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.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 workspace-book gadget-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 workspace-popup closable-gadget-content
+ live-search-list gadget-child "p" set ] unit-test
+
+ [ t ] [ "p" get presentation? ] unit-test
+
+ [ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
+
+ [ ] [ notify-queued ] unit-test
+
+ [ t ] [ "c" get button? ] unit-test
+
+ [ ] [
+ "w" get workspace-listener listener-gadget-input
+ 3 handle-parse-error
+ ] unit-test
+
+ [ ] [ notify-queued ] unit-test
+] with-grafted-gadget
--- /dev/null
+! Copyright (C) 2006, 2008 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 ;
+IN: ui.tools
+
+: <workspace-tabs> ( workspace -- tabs )
+ model>>
+ "tool-switching" workspace command-map commands>>
+ [ command-string ] { } assoc>map <enum> >alist
+ <toggle-buttons> ;
+
+: <workspace-book> ( workspace -- gadget )
+
+ dup
+ <stack-display>
+ <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
+
+ dup <workspace-tabs> f track-add
+ dup book>> 1/5 track-add
+ dup listener>> 4/5 track-add
+ dup <toolbar> f track-add ;
+
+: resize-workspace ( workspace -- )
+ dup track-sizes over control-value zero? [
+ 1/5 1 pick set-nth
+ 4/5 2 rot set-nth
+ ] [
+ 2/3 1 pick set-nth
+ 1/3 2 rot set-nth
+ ] if relayout ;
+
+M: workspace model-changed
+ nip
+ dup workspace-listener listener-gadget-output scroll>bottom
+ dup resize-workspace
+ request-focus ;
+
+[ workspace-window ] ui-hook set-global
+
+: com-listener ( workspace -- ) stack-display select-tool ;
+
+: com-browser ( workspace -- ) browser-gadget select-tool ;
+
+: com-inspector ( workspace -- ) inspector-gadget select-tool ;
+
+: com-profiler ( workspace -- ) profiler-gadget 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 }
+} 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 }
+ { 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 ] curry call-listener ;
+
+traceback-gadget "toolbar" f {
+ { T{ key-down f f "v" } variables }
+ { T{ key-down f f "n" } inspect-continuation }
+} define-command-map
--- /dev/null
+Slava Pestov
--- /dev/null
+Traceback gadgets display a continuation in human-readable form
--- /dev/null
+! Copyright (C) 2006, 2008 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 ;
+
+IN: ui.tools.traceback
+
+: <callstack-display> ( model -- gadget )
+ [ [ continuation-call callstack. ] when* ]
+ t "Call stack" <labelled-pane> ;
+
+: <datastack-display> ( model -- gadget )
+ [ [ continuation-data stack. ] when* ]
+ t "Data stack" <labelled-pane> ;
+
+: <retainstack-display> ( model -- gadget )
+ [ [ continuation-retain stack. ] when* ]
+ t "Retain stack" <labelled-pane> ;
+
+TUPLE: traceback-gadget < track ;
+
+M: traceback-gadget pref-dim* drop { 550 600 } ;
+
+: <traceback-gadget> ( model -- gadget )
+ { 0 1 } traceback-gadget new-track
+ swap >>model
+
+ dup model>>
+ { 1 0 } <track>
+ over <datastack-display> 1/2 track-add
+ swap <retainstack-display> 1/2 track-add
+ 1/3 track-add
+
+ dup model>> <callstack-display> 2/3 track-add
+
+ dup <toolbar> f track-add ;
+
+: <namestack-display> ( model -- gadget )
+ [ [ continuation-name namestack. ] when* ]
+ <pane-control> ;
+
+: <variables-gadget> ( model -- gadget )
+ <namestack-display> { 400 400 } <limited-scroller> ;
+
+: variables ( traceback -- )
+ gadget-model <variables-gadget>
+ "Dynamic variables" open-status-window ;
+
+: traceback-window ( continuation -- )
+ <model> <traceback-gadget> "Traceback" open-window ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Graphical code single stepper
--- /dev/null
+IN: ui.tools.walker\r
+USING: help.markup help.syntax ui.commands ui.operations\r
+ui.render tools.walker sequences ;\r
+\r
+ARTICLE: "ui-walker-step" "Stepping through code"\r
+"If the current position points to a word, the various stepping commands behave as follows:"\r
+{ $list\r
+ { { $link com-step } " executes the word and moves the current position one word further." }\r
+ { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." }\r
+ { { $link com-out } " executes until the end of the current quotation." }\r
+}\r
+"If the current position points to a literal, the various stepping commands behave as follows:"\r
+{ $list\r
+ { { $link com-step } " pushes the literal on the data stack." }\r
+ { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." }\r
+ { { $link com-out } " executes until the end of the current quotation." }\r
+}\r
+"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:"\r
+{ $code "{ 10 20 30 } [ 3 + . ] each" }\r
+"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:"\r
+{ $code "[ break 3 + . ]" }\r
+"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit."\r
+$nl\r
+"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;\r
+\r
+ARTICLE: "breakpoints" "Setting breakpoints"\r
+"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "."\r
+$nl\r
+"Breakpoints can be inserted directly into code:"\r
+{ $subsection break }\r
+"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;\r
+\r
+ARTICLE: "ui-walker" "UI walker"\r
+"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."\r
+$nl\r
+"Walkers are instances of " { $link walker-gadget } "."\r
+{ $subsection "ui-walker-step" }\r
+{ $subsection "breakpoints" }\r
+{ $command-map walker-gadget "toolbar" } ;\r
+\r
+ABOUT: "ui-walker"\r
--- /dev/null
+USING: ui.tools.walker tools.test ;
+IN: ui.tools.walker.tests
+
+\ <walker-gadget> must-infer
--- /dev/null
+! Copyright (C) 2006, 2008 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
+ui.gadgets.labels ui threads namespaces tools.walker assocs
+combinators ;
+IN: ui.tools.walker
+
+TUPLE: walker-gadget < track
+status continuation thread
+traceback
+closing? ;
+
+: walker-command ( walker msg -- )
+ swap
+ dup thread>> thread-registered?
+ [ thread>> send-synchronous drop ]
+ [ 2drop ]
+ if ;
+
+: com-step ( walker -- ) step walker-command ;
+
+: com-into ( walker -- ) step-into walker-command ;
+
+: com-out ( walker -- ) step-out walker-command ;
+
+: com-back ( walker -- ) step-back walker-command ;
+
+: com-continue ( walker -- ) step-all walker-command ;
+
+: com-abandon ( walker -- ) abandon walker-command ;
+
+M: walker-gadget ungraft*
+ [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
+
+M: walker-gadget focusable-child*
+ traceback>> ;
+
+: walker-state-string ( status thread -- string )
+ [
+ "Thread: " %
+ dup thread-name %
+ " (" %
+ swap {
+ { +stopped+ "Stopped" }
+ { +suspended+ "Suspended" }
+ { +running+ "Running" }
+ } at %
+ ")" %
+ drop
+ ] "" make ;
+
+: <thread-status> ( model thread -- gadget )
+ [ walker-state-string ] curry <filter> <label-control> ;
+
+: <walker-gadget> ( status continuation thread -- gadget )
+ { 0 1 } walker-gadget new-track
+ swap >>thread
+ swap >>continuation
+ swap >>status
+ dup continuation>> <traceback-gadget> >>traceback
+
+ dup <toolbar> f track-add
+ dup status>> self <thread-status> f track-add
+ dup traceback>> 1 track-add ;
+
+: walker-help ( -- ) "ui-walker" help-window ;
+
+\ walker-help H{ { +nullary+ t } } define-command
+
+walker-gadget "toolbar" f {
+ { T{ key-down f f "s" } com-step }
+ { T{ key-down f f "i" } com-into }
+ { T{ key-down f f "o" } com-out }
+ { T{ key-down f f "b" } com-back }
+ { T{ key-down f f "c" } com-continue }
+ { T{ key-down f f "a" } com-abandon }
+ { T{ key-down f f "d" } close-window }
+ { T{ key-down f f "F1" } walker-help }
+} define-command-map
+
+: walker-for-thread? ( thread gadget -- ? )
+ {
+ { [ dup walker-gadget? not ] [ 2drop f ] }
+ { [ dup walker-gadget-closing? ] [ 2drop f ] }
+ [ thread>> eq? ]
+ } cond ;
+
+: find-walker-window ( thread -- world/f )
+ [ swap walker-for-thread? ] curry find-window ;
+
+: walker-window ( status continuation thread -- )
+ [ <walker-gadget> ] [ thread-name ] bi open-status-window ;
+
+[
+ dup find-walker-window dup
+ [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
+] show-walker-hook set-global
--- /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, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes continuations help help.topics kernel models
+ sequences 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 assocs arrays namespaces accessors ;
+
+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 workspace-book gadget-model
+ set-model ;
+
+: select-tool ( workspace class -- ) swap show-tool drop ;
+
+: get-workspace* ( quot -- workspace )
+ [ >r dup workspace? r> [ drop f ] if ] curry 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-window ( topic -- )
+ [
+ <pane> [ [ help ] with-pane ] keep
+ { 550 700 } <limited-scroller>
+ ] keep
+ article-title 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* drop workspace-dim get ;
+
+M: workspace focusable-child*
+ dup workspace-popup [ ] [ workspace-listener ] ?if ;
+
+: workspace-page ( workspace -- gadget )
+ workspace-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
--- /dev/null
+Slava Pestov
--- /dev/null
+Gadget tree traversal
--- /dev/null
+IN: ui.traverse.tests
+USING: ui.gadgets ui.gadgets.labels namespaces sequences kernel
+math arrays tools.test io ui.gadgets.panes ui.traverse
+definitions compiler.units ;
+
+M: array gadget-children ;
+
+GENERIC: (flatten-tree) ( node -- )
+
+M: node (flatten-tree)
+ node-children [ (flatten-tree) ] each ;
+
+M: object (flatten-tree) , ;
+
+: flatten-tree ( seq -- newseq )
+ [ [ (flatten-tree) ] each ] { } make ;
+
+: gadgets-in-range ( frompath topath gadget -- seq )
+ gadget-subtree flatten-tree ;
+
+[ { "a" "b" "c" "d" } ] [
+ { 0 } { } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" "b" } ] [
+ { } { 1 } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" } ] [
+ { 0 } { 0 } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" "b" "c" } ] [
+ { 0 } { 2 } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" "b" "c" "d" } ] [
+ { 0 } { 3 } { "a" "b" "c" "d" } gadgets-in-range
+] unit-test
+
+[ { "a" "b" "c" "d" } ] [
+ { 0 0 } { 0 3 } { { "a" "b" "c" "d" } } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" "e" } ] [
+ { 0 1 } { 1 } { { "a" "b" "c" "d" } "e" } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" "e" "f" } ] [
+ { 0 1 } { 1 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" { "e" "f" "g" } "h" "i" } ] [
+ { 0 1 } { 2 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { "h" "i" } } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" { "e" "f" "g" } "h" } ] [
+ { 0 1 } { 2 0 0 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
+] unit-test
+
+[ { "b" "c" "d" { "e" "f" "g" } "h" "i" } ] [
+ { 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
+] unit-test
+
+[ { array gadget-children } forget ] with-compilation-unit
--- /dev/null
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences kernel math arrays io ui.gadgets
+generic combinators ;
+IN: ui.traverse
+
+TUPLE: node value children ;
+
+: traverse-step ( path gadget -- path' gadget' )
+ >r unclip r> gadget-children ?nth ;
+
+: make-node ( quot -- ) { } make node boa , ; inline
+
+: traverse-to-path ( topath gadget -- )
+ dup not [
+ 2drop
+ ] [
+ over empty? [
+ nip ,
+ ] [
+ [
+ 2dup gadget-children swap first head-slice %
+ tuck traverse-step traverse-to-path
+ ] make-node
+ ] if
+ ] if ;
+
+: traverse-from-path ( frompath gadget -- )
+ dup not [
+ 2drop
+ ] [
+ over empty? [
+ nip ,
+ ] [
+ [
+ 2dup traverse-step traverse-from-path
+ tuck gadget-children swap first 1+ tail-slice %
+ ] make-node
+ ] if
+ ] if ;
+
+: traverse-pre ( frompath gadget -- )
+ traverse-step traverse-from-path ;
+
+: (traverse-middle) ( frompath topath gadget -- )
+ >r >r first 1+ r> first r> gadget-children <slice> % ;
+
+: traverse-post ( topath gadget -- )
+ traverse-step traverse-to-path ;
+
+: traverse-middle ( frompath topath gadget -- )
+ [
+ 3dup nip traverse-pre
+ 3dup (traverse-middle)
+ 2dup traverse-post
+ 2nip
+ ] make-node ;
+
+DEFER: (gadget-subtree)
+
+: traverse-child ( frompath topath gadget -- )
+ dup -roll [
+ >r >r rest-slice r> r> traverse-step (gadget-subtree)
+ ] make-node ;
+
+: (gadget-subtree) ( frompath topath gadget -- )
+ {
+ { [ dup not ] [ 3drop ] }
+ { [ pick empty? pick empty? and ] [ 2nip , ] }
+ { [ pick empty? ] [ rot drop traverse-to-path ] }
+ { [ over empty? ] [ nip traverse-from-path ] }
+ { [ pick first pick first = ] [ traverse-child ] }
+ [ traverse-middle ]
+ } cond ;
+
+: gadget-subtree ( frompath topath gadget -- seq )
+ [ (gadget-subtree) ] { } make ;
+
+M: node gadget-text*
+ dup node-children swap node-value gadget-seq-text ;
+
+: gadget-text-range ( frompath topath gadget -- str )
+ gadget-subtree gadget-text ;
+
+: gadget-at-path ( parent path -- gadget )
+ [ swap nth-gadget ] each ;
--- /dev/null
+USING: help.markup help.syntax strings quotations debugger
+io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
+ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ;
+IN: ui
+
+HELP: windows
+{ $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
+
+{ windows open-window find-window } related-words
+
+HELP: open-window
+{ $values { "gadget" gadget } { "title" string } }
+{ $description "Opens a native window with the specified title." } ;
+
+HELP: set-fullscreen?
+{ $values { "?" "a boolean" } { "gadget" gadget } }
+{ $description "Sets and unsets fullscreen mode for the gadget's world." } ;
+
+HELP: fullscreen?
+{ $values { "gadget" gadget } { "?" "a boolean" } }
+{ $description "Queries the gadget's world to see if it is running in fullscreen mode." } ;
+
+{ fullscreen? set-fullscreen? } related-words
+
+HELP: find-window
+{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
+{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
+
+HELP: register-window
+{ $values { "world" world } { "handle" "a baackend-specific handle" } }
+{ $description "Adds a window to the global " { $link windows } " variable." }
+{ $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ;
+
+HELP: unregister-window
+{ $values { "handle" "a baackend-specific handle" } }
+{ $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: start-ui
+{ $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)
+{ $values { "world" world } }
+{ $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
+{ $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
+
+HELP: ui-try
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
+{ $notes "This is essentially a graphical variant of " { $link try } "." } ;
+
+ARTICLE: "ui-glossary" "UI glossary"
+{ $table
+ { "color specifier"
+ { "an array of four elements, all numbers between 0 and 1:"
+ { $list
+ "red"
+ "green"
+ "blue"
+ "alpha - 0 is completely transparent, 1 is completely opaque"
+ }
+ }
+ }
+ { "dimension" "a pair of integers denoting pixel size on screen" }
+ { "font specifier"
+ { "an array of three elements:"
+ { $list
+ { "font family - one of " { $snippet "serif" } ", " { $snippet "sans-serif" } " or " { $snippet "monospace" } }
+ { "font style - one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } }
+ "font size in points"
+ }
+ }
+ }
+ { "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) inherit from " { $link gadget } "." } }
+ { "label specifier" { "a string, " { $link f } " or a gadget. See " { $link "ui.gadgets.buttons" } } }
+ { "orientation specifier" { "one of " { $snippet "{ 0 1 }" } " or " { $snippet "{ 1 0 }" } ", with the former denoting vertical orientation and the latter denoting horizontal. Using a vector instead of symbolic constants allows these values to be directly useful in co-ordinate calculations" } }
+ { "point" "a pair of integers denoting a pixel location on screen" }
+} ;
+
+ARTICLE: "building-ui" "Building user interfaces"
+"A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "."
+{ $subsection gadget }
+"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $link gadget-parent } " slot."
+{ $subsection "ui-geometry" }
+{ $subsection "ui-layouts" }
+{ $subsection "gadgets" }
+{ $subsection "ui-windows" }
+{ $see-also "models" } ;
+
+ARTICLE: "gadgets" "Pre-made UI gadgets"
+{ $subsection "ui.gadgets.labels" }
+{ $subsection "gadgets-polygons" }
+{ $subsection "ui.gadgets.borders" }
+{ $subsection "ui.gadgets.labelled" }
+{ $subsection "ui.gadgets.buttons" }
+{ $subsection "ui.gadgets.sliders" }
+{ $subsection "ui.gadgets.scrollers" }
+{ $subsection "gadgets-editors" }
+{ $subsection "ui.gadgets.panes" }
+{ $subsection "ui.gadgets.presentations" }
+{ $subsection "ui.gadgets.lists" } ;
+
+ARTICLE: "ui-geometry" "Gadget geometry"
+"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
+{ $subsection rect }
+"Rectangles can be taken apart:"
+{ $subsection rect-loc }
+{ $subsection rect-dim }
+{ $subsection rect-bounds }
+{ $subsection rect-extent }
+"New rectangles can be created:"
+{ $subsection <zero-rect> }
+{ $subsection <rect> }
+{ $subsection <extent-rect> }
+"More utility words for working with rectangles:"
+{ $subsection offset-rect }
+{ $subsection rect-intersect }
+{ $subsection intersects? }
+"A gadget's bounding box is always relative to its parent:"
+{ $subsection gadget-parent }
+"Word for converting from a child gadget's co-ordinate system to a parent's:"
+{ $subsection relative-loc }
+{ $subsection screen-loc }
+"Hit testing:"
+{ $subsection pick-up }
+{ $subsection children-on } ;
+
+ARTICLE: "ui-windows" "Top-level windows"
+"Opening a top-level window:"
+{ $subsection open-window }
+"Finding top-level windows:"
+{ $subsection find-window }
+"Top-level windows are stored in a global variable:"
+{ $subsection windows }
+"When a gadget is displayed in a top-level window, or added to a parent which is already showing in a top-level window, a generic word is called allowing the gadget to perform initialization tasks:"
+{ $subsection graft* }
+"When the gadget is removed from a parent shown in a top-level window, or when the top-level window is closed, a corresponding generic word is called to clean up:"
+{ $subsection ungraft* }
+"The root of the gadget hierarchy in a window is a special gadget which is rarely operated on directly, but it is helpful to know it exists:"
+{ $subsection world } ;
+
+ARTICLE: "ui-backend" "Developing UI backends"
+"None of the words documented in this section should be called directly by user code. They are only of interest when developing new UI backends."
+{ $subsection "ui-backend-init" }
+{ $subsection "ui-backend-windows" }
+"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 word to start the UI:"
+{ $subsection ui }
+"This word should contain backend initialization, together with some boilerplate:"
+{ $code
+ "IN: shells"
+ ""
+ ": ui"
+ " ... backend-specific initialization ..."
+ " start-ui"
+ " ... more backend-specific initialization ..."
+ " ... start event loop here ... ;"
+}
+"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."
+$nl
+"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
+
+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:"
+{ $subsection open-world-window }
+"This word should create a native window, store some kind of handle in the " { $link world-handle } " slot, then call two words:"
+{ $subsection register-window }
+"The following words must also be implemented:"
+{ $subsection set-title }
+{ $subsection raise-window }
+"When a world needs to be redrawn, the UI will call a word automatically:"
+{ $subsection draw-world }
+"This word can also be called directly if the UI backend is notified by the window system that window contents have been invalidated. Before and after drawing, two words are called, which the UI backend must implement:"
+{ $subsection select-gl-context }
+{ $subsection flush-gl-context }
+"If the user clicks the window's close box, you must call the following word:"
+{ $subsection close-window } ;
+
+HELP: raise-window
+{ $values { "gadget" gadget } }
+{ $description "Makes the native window containing the given gadget the front-most window." } ;
+
+ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
+"A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."
+{ $subsection "ui-layout-basics" }
+{ $subsection "ui-layout-combinators" }
+"Common layout gadgets:"
+{ $subsection "ui-pack-layout" }
+{ $subsection "ui-track-layout" }
+{ $subsection "ui-grid-layout" }
+{ $subsection "ui-frame-layout" }
+{ $subsection "ui-book-layout" }
+"Advanced topics:"
+{ $subsection "ui-null-layout" }
+{ $subsection "ui-incremental-layout" }
+{ $subsection "ui-layout-impl" }
+{ $see-also "ui.gadgets.borders" } ;
+
+ARTICLE: "ui-layout-basics" "Layout basics"
+"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget."
+$nl
+"Managing the gadget hierarchy:"
+{ $subsection add-gadget }
+{ $subsection unparent }
+{ $subsection add-gadgets }
+{ $subsection clear-gadget }
+"Working with gadget children:"
+{ $subsection gadget-children }
+{ $subsection gadget-child }
+{ $subsection nth-gadget }
+{ $subsection each-child }
+{ $subsection child? }
+"Working with gadget parents:"
+{ $subsection parents }
+{ $subsection each-parent }
+{ $subsection find-parent }
+"Adding children, removing children and performing certain other operations initiates relayout requests automatically. In other cases, relayout may have to be triggered explicitly. There is no harm from doing this several times in a row as consecutive relayout requests are coalesced."
+{ $subsection relayout }
+{ $subsection relayout-1 }
+"Gadgets implement a generic word to inform their parents of their preferred size:"
+{ $subsection pref-dim* }
+"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ;
+
+ARTICLE: "ui-layout-combinators" "Creating layouts using combinators"
+"The " { $link make } " combinator provides a convenient way of constructing sequences by keeping the intermediate sequence off the stack until construction is done. The " { $link , } " and " { $link % } " words operate on this implicit sequence, reducing stack noise."
+$nl
+"Similar tools exist for constructing complex gadget hierarchies. Different words are used for different types of gadgets; see " { $link "ui-pack-layout" } ", " { $link "ui-track-layout" } " and " { $link "ui-frame-layout" } " for specifics. This section documents their common factors."
+;
+
+ARTICLE: "ui-null-layout" "Manual layouts"
+"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
+{ $subsection set-rect-loc } ;
+
+ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
+"The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:"
+{ $subsection layout* }
+"When a " { $link layout* } " method is called, the size and location of the gadget has already been determined by its parent, and the method's job is to lay out the gadget's children. Children can be positioned and resized with a pair of words:"
+{ $subsection set-rect-loc }
+"Some assorted utility words which are useful for implementing layout logic:"
+{ $subsection pref-dim }
+{ $subsection pref-dims }
+{ $subsection prefer }
+{ $subsection max-dim }
+{ $subsection dim-sum }
+{ $warning
+ "When implementing the " { $link layout* } " generic word for a gadget which inherits from another layout, the " { $link children-on } " word might have to be re-implemented as well."
+ $nl
+ "For example, suppose you want a " { $link grid } " layout which also displays a popup gadget on top. The implementation of " { $link children-on } " for the " { $link grid } " class determines which children of the grid are visible at one time, and this will never include your popup, so it will not be rendered, nor will it respond to gestures. The solution is to re-implement " { $link children-on } " on your class."
+} ;
+
+ARTICLE: "new-gadgets" "Implementing new gadgets"
+"One of the goals of the Factor UI is to minimize the need to implement new types of gadgets by offering a highly reusable, orthogonal set of building blocks. However, in some cases implementing a new type of gadget is necessary, for example when writing a graphical visualization."
+$nl
+"Bare gadgets can be constructed directly, which is useful if all you need is a custom appearance with no further behavior (see " { $link "ui-pen-protocol" } "):"
+{ $subsection <gadget> }
+"New gadgets are defined as subclasses of an existing gadget type, perhaps even " { $link gadget } " itself. A parametrized constructor should be used to construct subclasses:"
+{ $subsection new-gadget }
+"Further topics:"
+{ $subsection "ui-gestures" }
+{ $subsection "ui-paint" }
+{ $subsection "ui-control-impl" }
+{ $subsection "clipboard-protocol" }
+{ $see-also "ui-layout-impl" } ;
+
+ARTICLE: "ui" "UI framework"
+{ $subsection "ui-glossary" }
+{ $subsection "building-ui" }
+{ $subsection "new-gadgets" }
+{ $subsection "ui-backend" } ;
+
+ABOUT: "ui"
--- /dev/null
+! Copyright (C) 2006, 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs io kernel math models namespaces
+prettyprint dlists dequeues sequences threads sequences words
+debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
+ui.gestures ui.backend ui.render continuations init combinators
+hashtables concurrency.flags sets accessors ;
+IN: ui
+
+! Assoc mapping aliens to gadgets
+SYMBOL: windows
+
+SYMBOL: stop-after-last-window?
+
+: event-loop? ( -- ? )
+ {
+ { [ stop-after-last-window? get not ] [ t ] }
+ { [ graft-queue dequeue-empty? not ] [ t ] }
+ { [ windows get-global empty? not ] [ t ] }
+ [ f ]
+ } cond ;
+
+: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
+
+: window ( handle -- world ) windows get-global at ;
+
+: window-focus ( handle -- gadget ) window world-focus ;
+
+: register-window ( world handle -- )
+ #! Add the new window just below the topmost window. Why?
+ #! So that if the new window doesn't actually receive focus
+ #! (eg, we're using focus follows mouse and the mouse is not
+ #! in the new window when it appears) Factor doesn't get
+ #! confused and send workspace operations to the new window,
+ #! etc.
+ swap 2array windows get-global push
+ windows get-global dup length 1 >
+ [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
+
+: unregister-window ( handle -- )
+ windows global [ [ first = not ] with filter ] change-at ;
+
+: raised-window ( world -- )
+ windows get-global
+ [ [ second eq? ] with find drop ] keep
+ [ nth ] [ delete-nth ] [ nip ] 2tri push ;
+
+: focus-gestures ( new old -- )
+ drop-prefix <reversed>
+ T{ lose-focus } swap each-gesture
+ T{ gain-focus } swap each-gesture ;
+
+: focus-world ( world -- )
+ t over set-world-focused?
+ dup raised-window
+ focus-path f focus-gestures ;
+
+: unfocus-world ( world -- )
+ f over set-world-focused?
+ focus-path f swap focus-gestures ;
+
+M: world graft*
+ dup (open-window)
+ dup world-title over set-title
+ request-focus ;
+
+: reset-world ( world -- )
+ #! This is used when a window is being closed, but also
+ #! when restoring saved worlds on image startup.
+ dup world-fonts clear-assoc
+ dup unfocus-world
+ f swap set-world-handle ;
+
+M: world ungraft*
+ dup free-fonts
+ dup hand-clicked close-global
+ dup hand-gadget close-global
+ dup world-handle (close-window)
+ reset-world ;
+
+: find-window ( quot -- 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
+ V{ } clone windows set-global ;
+
+: restore-gadget-later ( gadget -- )
+ dup gadget-graft-state {
+ { { f f } [ ] }
+ { { f t } [ ] }
+ { { t t } [
+ { f f } over set-gadget-graft-state
+ ] }
+ { { t f } [
+ dup unqueue-graft
+ { f f } over set-gadget-graft-state
+ ] }
+ } case graft-later ;
+
+: restore-gadget ( gadget -- )
+ dup restore-gadget-later
+ gadget-children [ restore-gadget ] each ;
+
+: 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 ;
+
+: layout-queued ( -- seq )
+ [
+ in-layout? on
+ layout-queue [
+ dup layout find-world [ , ] when*
+ ] slurp-dequeue
+ ] { } make prune ;
+
+: redraw-worlds ( seq -- )
+ [ dup update-hand draw-world ] each ;
+
+: notify ( gadget -- )
+ dup gadget-graft-state
+ dup first { f f } { t t } ?
+ pick set-gadget-graft-state {
+ { { f t } [ dup activate-control graft* ] }
+ { { t f } [ dup deactivate-control ungraft* ] }
+ } case ;
+
+: notify-queued ( -- )
+ graft-queue [ notify ] slurp-dequeue ;
+
+: update-ui ( -- )
+ [ notify-queued layout-queued redraw-worlds ] assert-depth ;
+
+: ui-wait ( -- )
+ 10 sleep ;
+
+: ui-try ( quot -- ) [ ui-error ] recover ;
+
+SYMBOL: ui-thread
+
+: ui-running ( quot -- )
+ t \ ui-running set-global
+ [ f \ ui-running set-global ] [ ] cleanup ; inline
+
+: ui-running? ( -- ? )
+ \ ui-running get-global ;
+
+: update-ui-loop ( -- )
+ ui-running? ui-thread get-global self eq? and [
+ ui-notify-flag get lower-flag
+ [ update-ui ] ui-try
+ update-ui-loop
+ ] when ;
+
+: start-ui-thread ( -- )
+ [ self ui-thread set-global update-ui-loop ]
+ "UI update" spawn drop ;
+
+: open-world-window ( world -- )
+ dup pref-dim over (>>dim) dup relayout graft ;
+
+: open-window ( gadget title -- )
+ f <world> open-world-window ;
+
+: set-fullscreen? ( ? gadget -- )
+ find-world set-fullscreen* ;
+
+: fullscreen? ( gadget -- ? )
+ find-world fullscreen* ;
+
+: raise-window ( gadget -- )
+ find-world raise-window* ;
+
+HOOK: close-window ui-backend ( gadget -- )
+
+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 ;
+
+[
+ f \ ui-running set-global
+ <flag> ui-notify-flag set-global
+] "ui" add-init-hook
+
+HOOK: ui ui-backend ( -- )
+
+MAIN: ui
+
+: with-ui ( quot -- )
+ ui-running? [
+ call
+ ] [
+ f windows set-global
+ [
+ ui-hook set
+ stop-after-last-window? on
+ ui
+ ] with-scope
+ ] if ;
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2005, 2006 Doug Coleman.
+! Portions copyright (C) 2007, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings arrays assocs ui
+ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
+ui.gestures io kernel math math.vectors namespaces
+sequences strings vectors words windows.kernel32 windows.gdi32
+windows.user32 windows.opengl32 windows.messages windows.types
+windows.nt windows threads libc combinators continuations
+command-line shuffle opengl ui.render unicode.case ascii
+math.bitfields locals symbols accessors math.geometry.rect ;
+IN: ui.windows
+
+SINGLETON: windows-ui-backend
+
+: crlf>lf ( str -- str' )
+ CHAR: \r swap remove ;
+
+: lf>crlf ( str -- str' )
+ [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
+
+: enum-clipboard ( -- seq )
+ 0
+ [ EnumClipboardFormats win32-error dup dup 0 > ]
+ [ ]
+ [ drop ]
+ produce nip ;
+
+: with-clipboard ( quot -- )
+ f OpenClipboard win32-error=0/f
+ call
+ CloseClipboard win32-error=0/f ; inline
+
+: paste ( -- str )
+ [
+ CF_UNICODETEXT IsClipboardFormatAvailable zero? [
+ ! nothing to paste
+ ""
+ ] [
+ CF_UNICODETEXT GetClipboardData dup win32-error=0/f
+ dup GlobalLock dup win32-error=0/f
+ GlobalUnlock win32-error=0/f
+ utf16n alien>string
+ ] if
+ ] with-clipboard
+ crlf>lf ;
+
+: copy ( str -- )
+ lf>crlf [
+ utf16n string>alien
+ EmptyClipboard win32-error=0/f
+ GMEM_MOVEABLE over length 1+ GlobalAlloc
+ dup win32-error=0/f
+
+ dup GlobalLock dup win32-error=0/f
+ swapd byte-array>memory
+ dup GlobalUnlock win32-error=0/f
+ CF_UNICODETEXT swap SetClipboardData win32-error=0/f
+ ] with-clipboard ;
+
+TUPLE: pasteboard ;
+C: <pasteboard> pasteboard
+
+M: pasteboard clipboard-contents drop paste ;
+M: pasteboard set-clipboard-contents drop copy ;
+
+: init-clipboard ( -- )
+ <pasteboard> clipboard set-global
+ <clipboard> selection set-global ;
+
+! world-handle is a <win>
+TUPLE: win hWnd hDC hRC world title ;
+C: <win> win
+
+SYMBOLS: msg-obj class-name-ptr mouse-captured ;
+
+: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
+: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
+
+: get-RECT-top-left ( RECT -- x y )
+ [ RECT-left ] keep RECT-top ;
+
+: get-RECT-dimensions ( RECT -- x y width height )
+ [ get-RECT-top-left ] keep
+ [ RECT-right ] keep [ RECT-left - ] keep
+ [ RECT-bottom ] keep RECT-top - ;
+
+: handle-wm-paint ( hWnd uMsg wParam lParam -- )
+ #! wParam and lParam are unused
+ #! only paint if width/height both > 0
+ 3drop window relayout-1 yield ;
+
+: handle-wm-size ( hWnd uMsg wParam lParam -- )
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
+
+: handle-wm-move ( hWnd uMsg wParam lParam -- )
+ 2nip
+ [ lo-word ] keep hi-word 2array
+ swap window (>>window-loc) ;
+
+: wm-keydown-codes ( -- key )
+ H{
+ { 8 "BACKSPACE" }
+ { 9 "TAB" }
+ { 13 "RET" }
+ { 27 "ESC" }
+ { 33 "PAGE_UP" }
+ { 34 "PAGE_DOWN" }
+ { 35 "END" }
+ { 36 "HOME" }
+ { 37 "LEFT" }
+ { 38 "UP" }
+ { 39 "RIGHT" }
+ { 40 "DOWN" }
+ { 45 "INSERT" }
+ { 46 "DELETE" }
+ { 112 "F1" }
+ { 113 "F2" }
+ { 114 "F3" }
+ { 115 "F4" }
+ { 116 "F5" }
+ { 117 "F6" }
+ { 118 "F7" }
+ { 119 "F8" }
+ { 120 "F9" }
+ { 121 "F10" }
+ { 122 "F11" }
+ { 123 "F12" }
+ } ;
+
+: key-state-down? ( key -- ? )
+ GetKeyState 16 bit? ;
+
+: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
+: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
+: left-alt? ( -- ? ) VK_LMENU key-state-down? ;
+: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
+: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
+: right-alt? ( -- ? ) VK_RMENU key-state-down? ;
+: shift? ( -- ? ) left-shift? right-shift? or ;
+: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
+: alt? ( -- ? ) left-alt? right-alt? or ;
+: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
+
+: switch-case ( seq -- seq )
+ dup first CHAR: a >= [ >upper ] [ >lower ] if ;
+
+: switch-case? ( -- ? ) shift? caps-lock? xor not ;
+
+: key-modifiers ( -- seq )
+ [
+ shift? [ S+ , ] when
+ ctrl? [ C+ , ] when
+ alt? [ A+ , ] when
+ ] { } make [ empty? not ] keep f ? ;
+
+: exclude-keys-wm-keydown
+ H{
+ { 16 "SHIFT" }
+ { 17 "CTRL" }
+ { 18 "ALT" }
+ { 20 "CAPS-LOCK" }
+ } ;
+
+: exclude-keys-wm-char
+ ! Values are ignored
+ H{
+ { 8 "BACKSPACE" }
+ { 9 "TAB" }
+ { 13 "RET" }
+ { 27 "ESC" }
+ } ;
+
+: exclude-key-wm-keydown? ( n -- bool )
+ exclude-keys-wm-keydown key? ;
+
+: exclude-key-wm-char? ( n -- bool )
+ exclude-keys-wm-char key? ;
+
+: keystroke>gesture ( n -- mods sym ? )
+ dup wm-keydown-codes at* [
+ nip >r key-modifiers r> t
+ ] [
+ drop 1string >r key-modifiers r>
+ C+ pick member? >r A+ pick member? r> or [
+ shift? [ >lower ] unless f
+ ] [
+ switch-case? [ switch-case ] when t
+ ] if
+ ] if ;
+
+:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-keydown? [
+ wParam keystroke>gesture <key-down>
+ hWnd window-focus send-gesture drop
+ ] unless ;
+
+:: handle-wm-char ( hWnd uMsg wParam lParam -- )
+ wParam exclude-key-wm-char? ctrl? alt? xor or [
+ wParam 1string
+ hWnd window-focus user-input
+ ] unless ;
+
+:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
+ wParam keystroke>gesture <key-up>
+ hWnd window-focus send-gesture drop ;
+
+:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ ? hwnd window set-world-active?
+ hwnd uMsg wParam lParam DefWindowProc ;
+
+: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
+ {
+ { [ over SC_MINIMIZE = ] [ f set-window-active ] }
+ { [ over SC_RESTORE = ] [ t set-window-active ] }
+ { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
+ { [ dup alpha? ] [ 4drop 0 ] }
+ { [ t ] [ DefWindowProc ] }
+ } cond ;
+
+: cleanup-window ( handle -- )
+ dup win-title [ free ] when*
+ dup win-hRC wglDeleteContext win32-error=0/f
+ dup win-hWnd swap win-hDC ReleaseDC win32-error=0/f ;
+
+M: windows-ui-backend (close-window)
+ dup win-hWnd unregister-window
+ dup cleanup-window
+ win-hWnd DestroyWindow win32-error=0/f ;
+
+: handle-wm-close ( hWnd uMsg wParam lParam -- )
+ 3drop window ungraft ;
+
+: handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
+ 3drop window [ focus-world ] when* ;
+
+: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
+ 3drop window [ unfocus-world ] when* ;
+
+: message>button ( uMsg -- button down? )
+ {
+ { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] }
+ { [ dup WM_LBUTTONUP = ] [ drop 1 f ] }
+ { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] }
+ { [ dup WM_MBUTTONUP = ] [ drop 2 f ] }
+ { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] }
+ { [ dup WM_RBUTTONUP = ] [ drop 3 f ] }
+
+ { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] }
+ { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] }
+ { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] }
+ { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] }
+ { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] }
+ { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] }
+ } cond ;
+
+! If the user clicks in the window border ("non-client area")
+! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
+! mouse is subsequently released outside the NC area, we receive
+! a [LMR]BUTTONUP message and Factor can get confused. So we
+! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
+SYMBOL: nc-buttons
+
+: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
+ 2drop nip
+ message>button nc-buttons get
+ swap [ push ] [ delete ] if ;
+
+: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ;
+: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
+
+: mouse-absolute>relative ( lparam handle -- array )
+ >r >lo-hi r>
+ "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
+ get-RECT-top-left 2array v- ;
+
+: mouse-event>gesture ( uMsg -- button )
+ key-modifiers swap message>button
+ [ <button-down> ] [ <button-up> ] if ;
+
+: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
+ nip >r mouse-event>gesture r> >lo-hi rot window ;
+
+: set-capture ( hwnd -- )
+ mouse-captured get [
+ drop
+ ] [
+ [ SetCapture drop ] keep
+ mouse-captured set
+ ] if ;
+
+: release-capture ( -- )
+ ReleaseCapture win32-error=0/f
+ mouse-captured off ;
+
+: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
+ >r >r
+ over set-capture
+ dup message>button drop nc-buttons get delete
+ r> r> prepare-mouse send-button-down ;
+
+: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
+ mouse-captured get [ release-capture ] when
+ pick message>button drop dup nc-buttons get member? [
+ nc-buttons get delete 4drop
+ ] [
+ drop prepare-mouse send-button-up
+ ] if ;
+
+: make-TRACKMOUSEEVENT ( hWnd -- alien )
+ "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
+ "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
+
+: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
+ 2nip
+ over make-TRACKMOUSEEVENT
+ TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
+ 0 over set-TRACKMOUSEEVENT-dwHoverTime
+ TrackMouseEvent drop
+ >lo-hi swap window move-hand fire-motion ;
+
+: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
+ >r nip r>
+ pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
+
+: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
+ #! message sent if windows needs application to stop dragging
+ 4drop release-capture ;
+
+: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
+ #! message sent if mouse leaves main application
+ 4drop forget-rollover ;
+
+SYMBOL: wm-handlers
+
+H{ } clone wm-handlers set-global
+
+: add-wm-handler ( quot wm -- )
+ dup array?
+ [ [ execute add-wm-handler ] with each ]
+ [ wm-handlers get-global set-at ] if ;
+
+[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
+[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
+
+[ handle-wm-size 0 ] WM_SIZE add-wm-handler
+[ handle-wm-move 0 ] WM_MOVE add-wm-handler
+
+[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
+[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler
+[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler
+
+[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler
+[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
+[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
+
+[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
+[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
+[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
+[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
+
+[ 4dup handle-wm-ncbutton DefWindowProc ]
+{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
+WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
+add-wm-handler
+
+[ nc-buttons get-global delete-all DefWindowProc ]
+{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
+
+[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler
+[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
+[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
+[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
+
+SYMBOL: trace-messages?
+
+! return 0 if you handle the message, else just let DefWindowProc return its val
+: ui-wndproc ( -- object )
+ "uint" { "void*" "uint" "long" "long" } "stdcall" [
+ [
+ pick
+ trace-messages? get-global [ dup windows-message-name name>> print flush ] when
+ wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
+ ] ui-try
+ ] alien-callback ;
+
+: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
+
+M: windows-ui-backend do-events
+ msg-obj get-global
+ dup peek-message? [ drop ui-wait ] [
+ [ TranslateMessage drop ]
+ [ DispatchMessage drop ] bi
+ ] if ;
+
+: register-wndclassex ( -- class )
+ "WNDCLASSEX" <c-object>
+ f GetModuleHandle
+ class-name-ptr get-global
+ pick GetClassInfoEx zero? [
+ "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
+ { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
+ ui-wndproc over set-WNDCLASSEX-lpfnWndProc
+ 0 over set-WNDCLASSEX-cbClsExtra
+ 0 over set-WNDCLASSEX-cbWndExtra
+ f GetModuleHandle over set-WNDCLASSEX-hInstance
+ f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
+ over set-WNDCLASSEX-hIcon
+ f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
+
+ class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
+ RegisterClassEx dup win32-error=0/f
+ ] when ;
+
+: adjust-RECT ( RECT -- )
+ style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
+
+: make-RECT ( world -- RECT )
+ dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
+ "RECT" <c-object>
+ over first over set-RECT-right
+ swap second over set-RECT-bottom
+ over first over set-RECT-left
+ swap second over set-RECT-top ;
+
+: make-adjusted-RECT ( rect -- RECT )
+ make-RECT dup adjust-RECT ;
+
+: create-window ( rect -- hwnd )
+ make-adjusted-RECT
+ >r class-name-ptr get-global f r>
+ >r >r >r ex-style r> r>
+ { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
+ r> get-RECT-dimensions
+ f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
+
+: show-window ( hWnd -- )
+ dup SW_SHOW ShowWindow drop ! always succeeds
+ dup SetForegroundWindow drop
+ SetFocus drop ;
+
+: init-win32-ui ( -- )
+ V{ } clone nc-buttons set-global
+ "MSG" malloc-object msg-obj set-global
+ "Factor-window" utf16n malloc-string class-name-ptr set-global
+ register-wndclassex drop
+ GetDoubleClickTime double-click-timeout set-global ;
+
+: cleanup-win32-ui ( -- )
+ class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
+ msg-obj get-global [ free ] when*
+ f class-name-ptr set-global
+ f msg-obj set-global ;
+
+: setup-pixel-format ( hdc -- )
+ 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
+ swapd SetPixelFormat win32-error=0/f ;
+
+: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
+
+: get-rc ( hDC -- hRC )
+ dup wglCreateContext dup win32-error=0/f
+ [ wglMakeCurrent win32-error=0/f ] keep ;
+
+: setup-gl ( hwnd -- hDC hRC )
+ get-dc dup setup-pixel-format dup get-rc ;
+
+M: windows-ui-backend (open-window) ( world -- )
+ [ create-window dup setup-gl ] keep
+ [ f <win> ] keep
+ [ swap win-hWnd register-window ] 2keep
+ dupd set-world-handle
+ win-hWnd show-window ;
+
+M: windows-ui-backend select-gl-context ( handle -- )
+ [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ;
+
+M: windows-ui-backend flush-gl-context ( handle -- )
+ win-hDC SwapBuffers win32-error=0/f ;
+
+! Move window to front
+M: windows-ui-backend raise-window* ( world -- )
+ world-handle [
+ win-hWnd SetFocus drop
+ ] when* ;
+
+M: windows-ui-backend set-title ( string world -- )
+ world-handle
+ dup win-title [ free ] when*
+ >r utf16n malloc-string r>
+ 2dup set-win-title
+ win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;
+
+M: windows-ui-backend ui
+ [
+ [
+ stop-after-last-window? on
+ init-clipboard
+ init-win32-ui
+ start-ui
+ event-loop
+ ] [ cleanup-win32-ui ] [ ] cleanup
+ ] ui-running ;
+
+M: windows-ui-backend beep ( -- )
+ 0 MessageBeep drop ;
+
+windows-ui-backend ui-backend set-global
+
+[ "ui" ] main-vocab-hook set-global
--- /dev/null
+Slava Pestov
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays ui ui.gadgets
+ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
+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 debugger command-line qualified
+math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
+QUALIFIED: system
+IN: ui.x11
+
+SINGLETON: x11-ui-backend
+
+: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
+
+TUPLE: x11-handle window glx xic ;
+
+C: <x11-handle> x11-handle
+
+M: world expose-event nip relayout ;
+
+M: world configure-event
+ over configured-loc over (>>window-loc)
+ swap configured-dim over (>>dim)
+ ! In case dimensions didn't change
+ relayout-1 ;
+
+: modifiers
+ {
+ { S+ HEX: 1 }
+ { C+ HEX: 4 }
+ { A+ HEX: 8 }
+ } ;
+
+: key-codes
+ H{
+ { HEX: FF08 "BACKSPACE" }
+ { HEX: FF09 "TAB" }
+ { HEX: FF0D "RET" }
+ { HEX: FF8D "ENTER" }
+ { HEX: FF1B "ESC" }
+ { HEX: FFFF "DELETE" }
+ { HEX: FF50 "HOME" }
+ { HEX: FF51 "LEFT" }
+ { HEX: FF52 "UP" }
+ { HEX: FF53 "RIGHT" }
+ { HEX: FF54 "DOWN" }
+ { HEX: FF55 "PAGE_UP" }
+ { HEX: FF56 "PAGE_DOWN" }
+ { HEX: FF57 "END" }
+ { HEX: FF58 "BEGIN" }
+ { HEX: FFBE "F1" }
+ { HEX: FFBF "F2" }
+ { HEX: FFC0 "F3" }
+ { HEX: FFC1 "F4" }
+ { HEX: FFC2 "F5" }
+ { HEX: FFC3 "F6" }
+ { HEX: FFC4 "F7" }
+ { HEX: FFC5 "F8" }
+ { HEX: FFC6 "F9" }
+ } ;
+
+: key-code ( keysym -- keycode action? )
+ dup key-codes at [ t ] [ 1string f ] ?if ;
+
+: event-modifiers ( event -- seq )
+ XKeyEvent-state modifiers modifier ;
+
+: key-down-event>gesture ( event world -- string gesture )
+ dupd
+ world-handle x11-handle-xic lookup-string
+ >r swap event-modifiers r> key-code <key-down> ;
+
+M: world key-down-event
+ [ key-down-event>gesture ] keep world-focus
+ [ send-gesture ] keep swap [ user-input ] [ 2drop ] if ;
+
+: key-up-event>gesture ( event -- gesture )
+ dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
+
+M: world key-up-event
+ >r key-up-event>gesture r> world-focus send-gesture drop ;
+
+: mouse-event>gesture ( event -- modifiers button loc )
+ dup event-modifiers over XButtonEvent-button
+ rot mouse-event-loc ;
+
+M: world button-down-event
+ >r mouse-event>gesture >r <button-down> r> r>
+ send-button-down ;
+
+M: world button-up-event
+ >r mouse-event>gesture >r <button-up> r> r>
+ send-button-up ;
+
+: mouse-event>scroll-direction ( event -- pair )
+ XButtonEvent-button {
+ { 4 { 0 -1 } }
+ { 5 { 0 1 } }
+ { 6 { -1 0 } }
+ { 7 { 1 0 } }
+ } at ;
+
+M: world wheel-event
+ >r dup mouse-event>scroll-direction swap mouse-event-loc r>
+ send-wheel ;
+
+M: world enter-event motion-event ;
+
+M: world leave-event 2drop forget-rollover ;
+
+M: world motion-event
+ >r dup XMotionEvent-x swap XMotionEvent-y 2array r>
+ move-hand fire-motion ;
+
+M: world focus-in-event
+ nip
+ dup world-handle x11-handle-xic XSetICFocus focus-world ;
+
+M: world focus-out-event
+ nip
+ dup world-handle x11-handle-xic XUnsetICFocus unfocus-world ;
+
+M: world selection-notify-event
+ [ world-handle x11-handle-window selection-from-event ] keep
+ world-focus user-input ;
+
+: supported-type? ( atom -- ? )
+ { "UTF8_STRING" "STRING" "TEXT" }
+ [ x-atom = ] with contains? ;
+
+: clipboard-for-atom ( atom -- clipboard )
+ {
+ { [ dup XA_PRIMARY = ] [ drop selection get ] }
+ { [ dup XA_CLIPBOARD = ] [ drop clipboard get ] }
+ [ drop <clipboard> ]
+ } cond ;
+
+: encode-clipboard ( string type -- bytes )
+ XSelectionRequestEvent-target
+ XA_UTF8_STRING = utf8 ascii ? encode ;
+
+: set-selection-prop ( evt -- )
+ dpy get swap
+ [ XSelectionRequestEvent-requestor ] keep
+ [ XSelectionRequestEvent-property ] keep
+ [ XSelectionRequestEvent-target ] keep
+ >r 8 PropModeReplace r>
+ [
+ XSelectionRequestEvent-selection
+ clipboard-for-atom x-clipboard-contents
+ ] keep encode-clipboard dup length XChangeProperty drop ;
+
+M: world selection-request-event
+ drop dup XSelectionRequestEvent-target {
+ { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
+ { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
+ { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
+ [ drop send-notify-failure ]
+ } cond ;
+
+M: x11-ui-backend (close-window) ( handle -- )
+ dup x11-handle-xic XDestroyIC
+ dup x11-handle-glx destroy-glx
+ x11-handle-window dup unregister-window
+ destroy-window ;
+
+M: world client-event
+ swap close-box? [ ungraft ] [ drop ] if ;
+
+: gadget-window ( world -- )
+ dup window-loc>> over rect-dim glx-window
+ over "Factor" create-xic <x11-handle>
+ 2dup x11-handle-window register-window
+ swap set-world-handle ;
+
+: wait-event ( -- event )
+ QueuedAfterFlush events-queued 0 > [
+ next-event dup
+ None XFilterEvent zero? [ drop wait-event ] unless
+ ] [
+ ui-wait wait-event
+ ] if ;
+
+M: x11-ui-backend do-events
+ wait-event dup XAnyEvent-window window dup
+ [ [ 2dup handle-event ] assert-depth ] when 2drop ;
+
+: x-clipboard@ ( gadget clipboard -- prop win )
+ x-clipboard-atom swap
+ find-world world-handle x11-handle-window ;
+
+M: x-clipboard copy-clipboard
+ [ x-clipboard@ own-selection ] keep
+ set-x-clipboard-contents ;
+
+M: x-clipboard paste-clipboard
+ >r find-world world-handle x11-handle-window
+ r> x-clipboard-atom convert-selection ;
+
+: init-clipboard ( -- )
+ XA_PRIMARY <x-clipboard> selection set-global
+ XA_CLIPBOARD <x-clipboard> clipboard set-global ;
+
+: set-title-old ( dpy window string -- )
+ dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
+
+: set-title-new ( dpy window string -- )
+ >r
+ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
+ r> utf8 encode dup length XChangeProperty drop ;
+
+M: x11-ui-backend set-title ( string world -- )
+ world-handle x11-handle-window swap dpy get -rot
+ 3dup set-title-old set-title-new ;
+
+M: x11-ui-backend set-fullscreen* ( ? world -- )
+ world-handle x11-handle-window "XClientMessageEvent" <c-object>
+ tuck set-XClientMessageEvent-window
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
+ over set-XClientMessageEvent-data0
+ ClientMessage over set-XClientMessageEvent-type
+ dpy get over set-XClientMessageEvent-display
+ "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
+ 32 over set-XClientMessageEvent-format
+ "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
+ >r dpy get root get 0 SubstructureNotifyMask r> XSendEvent drop ;
+
+
+M: x11-ui-backend (open-window) ( world -- )
+ dup gadget-window
+ world-handle x11-handle-window dup set-closable map-window ;
+
+M: x11-ui-backend raise-window* ( world -- )
+ world-handle [
+ dpy get swap x11-handle-window XRaiseWindow drop
+ ] when* ;
+
+M: x11-ui-backend select-gl-context ( handle -- )
+ dpy get swap
+ dup x11-handle-window swap x11-handle-glx glXMakeCurrent
+ [ "Failed to set current GLX context" throw ] unless ;
+
+M: x11-ui-backend flush-gl-context ( handle -- )
+ dpy get swap x11-handle-window glXSwapBuffers ;
+
+M: x11-ui-backend ui ( -- )
+ [
+ f [
+ [
+ stop-after-last-window? on
+ init-clipboard
+ start-ui
+ event-loop
+ ] with-xim
+ ] with-x
+ ] ui-running ;
+
+M: x11-ui-backend beep ( -- )
+ dpy get 100 XBell drop ;
+
+x11-ui-backend ui-backend set-global
+
+[ "DISPLAY" system:os-env "ui" "listener" ? ]
+main-vocab-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces opengl opengl.gl ;
-IN: ui.backend
-
-SYMBOL: ui-backend
-
-HOOK: do-events ui-backend ( -- )
-
-HOOK: set-title ui-backend ( string world -- )
-
-HOOK: set-fullscreen* ui-backend ( ? world -- )
-
-HOOK: fullscreen* ui-backend ( world -- ? )
-
-HOOK: (open-window) ui-backend ( world -- )
-
-HOOK: (close-window) ui-backend ( handle -- )
-
-HOOK: raise-window* ui-backend ( world -- )
-
-HOOK: select-gl-context ui-backend ( handle -- )
-
-HOOK: flush-gl-context ui-backend ( handle -- )
-
-HOOK: beep ui-backend ( -- )
-
-: with-gl-context ( handle quot -- )
- swap [ select-gl-context call ] keep
- glFlush flush-gl-context gl-error ; inline
+++ /dev/null
-UI backend hooks
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets ui.gestures help.markup help.syntax strings ;
-IN: ui.clipboards
-
-HELP: clipboard
-{ $var-description "Global variable holding the system clipboard. By convention, text should only be copied to the clipboard via an explicit user action, for example by pressing " { $snippet "C+c" } "." }
-{ $class-description "A mutable container for a single string implementing the " { $link "clipboard-protocol" } "." } ;
-
-HELP: paste-clipboard
-{ $values { "gadget" gadget } { "clipboard" "an object" } }
-{ $contract "Arranges for the contents of the clipboard to be inserted into the gadget at some point in the near future via a call to " { $link user-input } ". The gadget must be grafted." } ;
-
-HELP: copy-clipboard
-{ $values { "string" string } { "gadget" gadget } { "clipboard" "an object" } }
-{ $contract "Arranges for the string to be copied to the clipboard on behalf of the gadget. The gadget must be grafted." } ;
-
-HELP: selection
-{ $var-description "Global variable holding the system selection. By convention, text should be copied to the selection as soon as it is selected by the user." } ;
-
-ARTICLE: "clipboard-protocol" "Clipboard protocol"
-"Custom gadgets that wish to interact with the clipboard must use the following two generic words to read and write clipboard contents:"
-{ $subsection paste-clipboard }
-{ $subsection copy-clipboard }
-"UI backends can either implement the above two words in the case of an asynchronous clipboard model (for example, X11). If direct access to the clipboard is provided (Windows, Mac OS X), the following two generic words may be implemented instead:"
-{ $subsection clipboard-contents }
-{ $subsection set-clipboard-contents }
-"However, gadgets should not call these words, since they will fail if only the asynchronous method of clipboard access is supported by the backend in use."
-$nl
-"Access to two clipboards is provided:"
-{ $subsection clipboard }
-{ $subsection selection }
-"These variables may contain clipboard protocol implementations which transfer data to and from the native system clipboard. However an UI backend may leave one or both of these variables in their default state, which is a trivial clipboard implementation internal to the Factor UI." ;
-
-ABOUT: "clipboard-protocol"
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ui.gadgets ui.gestures namespaces ;
-IN: ui.clipboards
-
-! Two text transfer buffers
-TUPLE: clipboard contents ;
-: <clipboard> ( -- clipboard ) "" clipboard boa ;
-
-GENERIC: paste-clipboard ( gadget clipboard -- )
-
-M: object paste-clipboard
- clipboard-contents dup [ swap user-input ] [ 2drop ] if ;
-
-GENERIC: copy-clipboard ( string gadget clipboard -- )
-
-M: object copy-clipboard nip set-clipboard-contents ;
-
-SYMBOL: clipboard
-SYMBOL: selection
-
-: gadget-copy ( gadget clipboard -- )
- over gadget-selection? [
- >r [ gadget-selection ] keep r> copy-clipboard
- ] [
- 2drop
- ] if ;
-
-: com-copy ( gadget -- ) clipboard get gadget-copy ;
-
-: com-copy-selection ( gadget -- ) selection get gadget-copy ;
+++ /dev/null
-Abstract clipboard support
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math arrays cocoa cocoa.application
-command-line kernel memory namespaces cocoa.messages
-cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
-cocoa.windows cocoa.classes cocoa.application sequences system
-ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.cocoa.views core-foundation threads math.geometry.rect ;
-IN: ui.cocoa
-
-TUPLE: handle view window ;
-
-C: <handle> handle
-
-SINGLETON: cocoa-ui-backend
-
-M: cocoa-ui-backend do-events ( -- )
- [
- [ NSApp [ do-event ] curry loop ui-wait ] ui-try
- ] with-autorelease-pool ;
-
-TUPLE: pasteboard handle ;
-
-C: <pasteboard> pasteboard
-
-M: pasteboard clipboard-contents
- pasteboard-handle pasteboard-string ;
-
-M: pasteboard set-clipboard-contents
- pasteboard-handle set-pasteboard-string ;
-
-: init-clipboard ( -- )
- NSPasteboard -> generalPasteboard <pasteboard>
- clipboard set-global
- <clipboard> selection set-global ;
-
-: world>NSRect ( world -- NSRect )
- dup window-loc>> first2 rot rect-dim first2 <NSRect> ;
-
-: gadget-window ( world -- )
- [
- dup <FactorView>
- dup rot world>NSRect <ViewWindow>
- dup install-window-delegate
- over -> release
- <handle>
- ] keep set-world-handle ;
-
-M: cocoa-ui-backend set-title ( string world -- )
- world-handle handle-window swap <NSString> -> setTitle: ;
-
-: enter-fullscreen ( world -- )
- world-handle handle-view
- NSScreen -> mainScreen
- f -> enterFullScreenMode:withOptions:
- drop ;
-
-: exit-fullscreen ( world -- )
- world-handle handle-view f -> exitFullScreenModeWithOptions: ;
-
-M: cocoa-ui-backend set-fullscreen* ( ? world -- )
- swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
-
-M: cocoa-ui-backend fullscreen* ( world -- ? )
- world-handle handle-view -> isInFullScreenMode zero? not ;
-
-: auto-position ( world -- )
- dup window-loc>> { 0 0 } = [
- world-handle handle-window -> center
- ] [
- drop
- ] if ;
-
-M: cocoa-ui-backend (open-window) ( world -- )
- dup gadget-window
- dup auto-position
- world-handle handle-window f -> makeKeyAndOrderFront: ;
-
-M: cocoa-ui-backend (close-window) ( handle -- )
- handle-window -> release ;
-
-M: cocoa-ui-backend close-window ( gadget -- )
- find-world [
- world-handle [
- handle-window f -> performClose:
- ] when*
- ] when* ;
-
-M: cocoa-ui-backend raise-window* ( world -- )
- world-handle [
- handle-window dup f -> orderFront: -> makeKeyWindow
- NSApp 1 -> activateIgnoringOtherApps:
- ] when* ;
-
-M: cocoa-ui-backend select-gl-context ( handle -- )
- handle-view -> openGLContext -> makeCurrentContext ;
-
-M: cocoa-ui-backend flush-gl-context ( handle -- )
- handle-view -> openGLContext -> flushBuffer ;
-
-M: cocoa-ui-backend beep ( -- )
- NSBeep ;
-
-SYMBOL: cocoa-init-hook
-
-M: cocoa-ui-backend ui
- "UI" assert.app [
- [
- init-clipboard
- cocoa-init-hook get [ call ] when*
- start-ui
- finish-launching
- event-loop
- ] ui-running
- ] with-cocoa ;
-
-cocoa-ui-backend ui-backend set-global
-
-[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
+++ /dev/null
-Cocoa UI backend
+++ /dev/null
-unportable
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Cocoa integration for UI developer tools
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2006, 2007 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 help.topics kernel memory namespaces parser
-system ui ui.tools.browser ui.tools.listener ui.tools.workspace
-ui.cocoa eval ;
-IN: ui.cocoa.tools
-
-: finder-run-files ( alien -- )
- CF>string-array listener-run-files
- NSApp NSApplicationDelegateReplySuccess
- -> replyToOpenOrPrint: ;
-
-: menu-run-files ( -- )
- open-panel [ listener-run-files ] when* ;
-
-: menu-save-image ( -- )
- image save-panel [ save-image ] when* ;
-
-! Handle Open events from the Finder
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorApplicationDelegate" }
-}
-
-{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
- [ >r 3drop r> finder-run-files ]
-}
-
-{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }
- [ 3drop workspace-window f ]
-}
-
-{ "runFactorFile:" "id" { "id" "SEL" "id" }
- [ 3drop menu-run-files f ]
-}
-
-{ "saveFactorImage:" "id" { "id" "SEL" "id" }
- [ 3drop save f ]
-}
-
-{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
- [ 3drop menu-save-image f ]
-}
-
-{ "showFactorHelp:" "id" { "id" "SEL" "id" }
- [ 3drop "handbook" com-follow f ]
-} ;
-
-: install-app-delegate ( -- )
- NSApp FactorApplicationDelegate install-delegate ;
-
-! Service support; evaluate Factor code from other apps
-: do-service ( pboard error quot -- )
- pick >r >r
- ?pasteboard-string dup [ r> call ] [ r> 2drop f ] if
- dup [ r> set-pasteboard-string ] [ r> 2drop ] if ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorServiceProvider" }
-} {
- "evalInListener:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "void*" }
- [ nip [ eval-listener f ] do-service 2drop ]
-} {
- "evalToString:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "void*" }
- [ nip [ eval>string ] do-service 2drop ]
-} ;
-
-: register-services ( -- )
- NSApp
- FactorServiceProvider -> alloc -> init
- -> setServicesProvider: ;
-
-FUNCTION: void NSUpdateDynamicServices ;
-
-[
- install-app-delegate
- "Factor.nib" load-nib
- register-services
-] cocoa-init-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Cocoa NSView implementation displaying Factor gadgets
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays assocs cocoa kernel
-math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
-cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
-sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
-core-foundation threads combinators math.geometry.rect ;
-IN: ui.cocoa.views
-
-: send-mouse-moved ( view event -- )
- over >r mouse-location r> window move-hand fire-motion ;
-
-: button ( event -- n )
- #! Cocoa -> Factor UI button mapping
- -> buttonNumber H{ { 0 1 } { 2 2 } { 1 3 } } at ;
-
-: modifiers
- {
- { S+ HEX: 20000 }
- { C+ HEX: 40000 }
- { A+ HEX: 80000 }
- { M+ HEX: 100000 }
- } ;
-
-: key-codes
- H{
- { 71 "CLEAR" }
- { 36 "RET" }
- { 76 "ENTER" }
- { 53 "ESC" }
- { 48 "TAB" }
- { 51 "BACKSPACE" }
- { 115 "HOME" }
- { 117 "DELETE" }
- { 119 "END" }
- { 122 "F1" }
- { 120 "F2" }
- { 99 "F3" }
- { 118 "F4" }
- { 96 "F5" }
- { 97 "F6" }
- { 98 "F7" }
- { 100 "F8" }
- { 123 "LEFT" }
- { 124 "RIGHT" }
- { 125 "DOWN" }
- { 126 "UP" }
- { 116 "PAGE_UP" }
- { 121 "PAGE_DOWN" }
- } ;
-
-: key-code ( event -- string ? )
- dup -> keyCode key-codes at
- [ t ] [ -> charactersIgnoringModifiers CF>string f ] ?if ;
-
-: event-modifiers ( event -- modifiers )
- -> modifierFlags modifiers modifier ;
-
-: key-event>gesture ( event -- modifiers keycode action? )
- dup event-modifiers swap key-code ;
-
-: send-key-event ( view event quot -- ? )
- >r key-event>gesture r> call swap window-focus
- send-gesture ; inline
-
-: send-user-input ( view string -- )
- CF>string swap window-focus user-input ;
-
-: interpret-key-event ( view event -- )
- NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
-
-: send-key-down-event ( view event -- )
- 2dup [ <key-down> ] send-key-event
- [ interpret-key-event ] [ 2drop ] if ;
-
-: send-key-up-event ( view event -- )
- [ <key-up> ] send-key-event drop ;
-
-: mouse-event>gesture ( event -- modifiers button )
- dup event-modifiers swap button ;
-
-: send-button-down$ ( view event -- )
- [ mouse-event>gesture <button-down> ] 2keep
- mouse-location rot window send-button-down ;
-
-: send-button-up$ ( view event -- )
- [ mouse-event>gesture <button-up> ] 2keep
- mouse-location rot window send-button-up ;
-
-: send-wheel$ ( view event -- )
- over >r
- dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
- mouse-location
- r> window send-wheel ;
-
-: send-action$ ( view event gesture -- junk )
- >r drop window r> send-action f ;
-
-: add-resize-observer ( observer object -- )
- >r "updateFactorGadgetSize:"
- "NSViewFrameDidChangeNotification" <NSString>
- r> add-observer ;
-
-: string-or-nil? ( NSString -- ? )
- [ CF>string NSStringPboardType = ] [ t ] if* ;
-
-: valid-service? ( gadget send-type return-type -- ? )
- over string-or-nil? over string-or-nil? and [
- drop [ gadget-selection? ] [ drop t ] if
- ] [
- 3drop f
- ] if ;
-
-: NSRect>rect ( NSRect world -- rect )
- >r dup NSRect-x over NSRect-y r>
- rect-dim second swap - 2array
- over NSRect-w rot NSRect-h 2array
- <rect> ;
-
-: rect>NSRect ( rect world -- NSRect )
- over rect-loc first2 rot rect-dim second swap -
- rot rect-dim first2 <NSRect> ;
-
-CLASS: {
- { +superclass+ "NSOpenGLView" }
- { +name+ "FactorView" }
- { +protocols+ { "NSTextInput" } }
-}
-
-! Rendering
-! Rendering
-{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
- [ 3drop window relayout-1 ]
-}
-
-! Events
-{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
- [ 3drop 1 ]
-}
-
-{ "mouseEntered:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "mouseExited:" "void" { "id" "SEL" "id" }
- [ [ 3drop forget-rollover ] ui-try ]
-}
-
-{ "mouseMoved:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "mouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
- [ [ nip send-mouse-moved ] ui-try ]
-}
-
-{ "mouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
-}
-
-{ "mouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
-}
-
-{ "rightMouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
-}
-
-{ "rightMouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
-}
-
-{ "otherMouseDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-down$ ] ui-try ]
-}
-
-{ "otherMouseUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-button-up$ ] ui-try ]
-}
-
-{ "scrollWheel:" "void" { "id" "SEL" "id" }
- [ [ nip send-wheel$ ] ui-try ]
-}
-
-{ "keyDown:" "void" { "id" "SEL" "id" }
- [ [ nip send-key-down-event ] ui-try ]
-}
-
-{ "keyUp:" "void" { "id" "SEL" "id" }
- [ [ nip send-key-up-event ] ui-try ]
-}
-
-{ "cut:" "id" { "id" "SEL" "id" }
- [ [ nip T{ cut-action } send-action$ ] ui-try ]
-}
-
-{ "copy:" "id" { "id" "SEL" "id" }
- [ [ nip T{ copy-action } send-action$ ] ui-try ]
-}
-
-{ "paste:" "id" { "id" "SEL" "id" }
- [ [ nip T{ paste-action } send-action$ ] ui-try ]
-}
-
-{ "delete:" "id" { "id" "SEL" "id" }
- [ [ nip T{ delete-action } send-action$ ] ui-try ]
-}
-
-{ "selectAll:" "id" { "id" "SEL" "id" }
- [ [ nip T{ select-all-action } send-action$ ] ui-try ]
-}
-
-! Multi-touch gestures: this is undocumented.
-! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
-{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
- [
- nip
- dup -> deltaZ sgn {
- { 1 [ T{ zoom-in-action } send-action$ ] }
- { -1 [ T{ zoom-out-action } send-action$ ] }
- { 0 [ 2drop ] }
- } case
- ]
-}
-
-{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
- [
- nip
- dup -> deltaX sgn {
- { 1 [ T{ left-action } send-action$ ] }
- { -1 [ T{ right-action } send-action$ ] }
- { 0
- [
- dup -> deltaY sgn {
- { 1 [ T{ up-action } send-action$ ] }
- { -1 [ T{ down-action } send-action$ ] }
- { 0 [ 2drop ] }
- } case
- ]
- }
- } case
- ]
-}
-
-! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
-
-{ "acceptsFirstResponder" "bool" { "id" "SEL" }
- [ 2drop 1 ]
-}
-
-! Services
-{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
- [
- ! We return either self or nil
- >r >r over window-focus r> r>
- valid-service? [ drop ] [ 2drop f ] if
- ]
-}
-
-{ "writeSelectionToPasteboard:types:" "bool" { "id" "SEL" "id" "id" }
- [
- CF>string-array NSStringPboardType swap member? [
- >r drop window-focus gadget-selection dup [
- r> set-pasteboard-string t
- ] [
- r> 2drop f
- ] if
- ] [
- 3drop f
- ] if
- ]
-}
-
-{ "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" }
- [
- pasteboard-string dup [
- >r drop window-focus r> swap user-input t
- ] [
- 3drop f
- ] if
- ]
-}
-
-! Text input
-{ "insertText:" "void" { "id" "SEL" "id" }
- [ [ nip send-user-input ] ui-try ]
-}
-
-{ "hasMarkedText" "bool" { "id" "SEL" }
- [ 2drop 0 ]
-}
-
-{ "markedRange" "NSRange" { "id" "SEL" }
- [ 2drop 0 0 <NSRange> ]
-}
-
-{ "selectedRange" "NSRange" { "id" "SEL" }
- [ 2drop 0 0 <NSRange> ]
-}
-
-{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
- [ 2drop 2drop ]
-}
-
-{ "unmarkText" "void" { "id" "SEL" }
- [ 2drop ]
-}
-
-{ "validAttributesForMarkedText" "id" { "id" "SEL" }
- [ 2drop NSArray -> array ]
-}
-
-{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
- [ 3drop f ]
-}
-
-{ "characterIndexForPoint:" "uint" { "id" "SEL" "NSPoint" }
- [ 3drop 0 ]
-}
-
-{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
- [ 3drop 0 0 0 0 <NSRect> ]
-}
-
-{ "conversationIdentifier" "long" { "id" "SEL" }
- [ drop alien-address ]
-}
-
-! Initialization
-{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
- [
- [
- 2drop dup view-dim swap window (>>dim) yield
- ] ui-try
- ]
-}
-
-{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
- [
- rot drop
- SUPER-> initWithFrame:pixelFormat:
- dup dup add-resize-observer
- ]
-}
-
-{ "dealloc" "void" { "id" "SEL" }
- [
- drop
- dup unregister-window
- dup remove-observer
- SUPER-> dealloc
- ]
-} ;
-
-: sync-refresh-to-screen ( GLView -- )
- -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
- CGLSetParameter drop ;
-
-: <FactorView> ( world -- view )
- FactorView over rect-dim <GLView>
- [ sync-refresh-to-screen ] keep
- [ register-window ] keep ;
-
-CLASS: {
- { +superclass+ "NSObject" }
- { +name+ "FactorWindowDelegate" }
-}
-
-{ "windowDidMove:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object
- dup window-content-rect NSRect-x-y 2array
- swap -> contentView window (>>window-loc)
- ]
-}
-
-{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object -> contentView window focus-world
- ]
-}
-
-{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
- [
- forget-rollover
- 2nip -> object -> contentView window unfocus-world
- ]
-}
-
-{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
- [
- 3drop t
- ]
-}
-
-{ "windowWillClose:" "void" { "id" "SEL" "id" }
- [
- 2nip -> object -> contentView window ungraft
- ]
-} ;
-
-: install-window-delegate ( window -- )
- FactorWindowDelegate install-delegate ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: accessors ui.gestures help.markup help.syntax strings kernel
-hashtables quotations words classes sequences namespaces
-arrays assocs ;
-IN: ui.commands
-
-: command-map-row ( gesture command -- seq )
- [
- [ gesture>string , ]
- [
- [ command-name , ]
- [ command-word \ $link swap 2array , ]
- [ command-description , ]
- tri
- ] bi*
- ] { } make ;
-
-: command-map. ( alist -- )
- [ command-map-row ] { } assoc>map
- { "Shortcut" "Command" "Word" "Notes" }
- [ \ $strong swap ] { } map>assoc prefix
- $table ;
-
-: $command-map ( element -- )
- [ second (command-name) " commands" append $heading ]
- [
- first2 swap command-map
- [ blurb>> print-element ] [ commands>> command-map. ] bi
- ] bi ;
-
-: $command ( element -- )
- reverse first3 command-map
- commands>> value-at gesture>string
- $snippet ;
-
-HELP: +nullary+
-{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, the command does not take any inputs, and the value passed to " { $link invoke-command } " will be ignored. Otherwise, it takes one input." } ;
-
-HELP: +listener+
-{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". If set to a true value, " { $link invoke-command } " will run the command in the listener. Otherwise it will run in the event loop." } ;
-
-HELP: +description+
-{ $description "A key which may be set in the hashtable passed to " { $link define-command } ". The value is a string displayed as part of the command's documentation by " { $link $command-map } "." } ;
-
-HELP: invoke-command
-{ $values { "target" object } { "command" "a command" } }
-{ $description "Invokes a command on the given target object." } ;
-
-{ invoke-command +nullary+ } related-words
-
-HELP: command-name
-{ $values { "command" "a command" } { "str" "a string" } }
-{ $description "Outputs a human-readable name for the command." }
-{ $examples
- { $example
- "USING: io ui.commands ;"
- "IN: scratchpad"
- ": com-my-command ;"
- "\\ com-my-command command-name write"
- "My Command"
- }
-} ;
-
-HELP: command-description
-{ $values { "command" "a command" } { "str/f" "a string or " { $link f } } }
-{ $description "Outputs the command's description." } ;
-
-{ command-description +description+ } related-words
-
-HELP: command-word
-{ $values { "command" "a command" } { "word" word } }
-{ $description "Outputs the word that will be executed by " { $link invoke-command } ". This is only used for documentation purposes." } ;
-
-HELP: command-map
-{ $values { "group" string } { "class" "a class word" } { "command-map" "a " { $link command-map } " or " { $link f } } }
-{ $description "Outputs a named command map defined on a class." }
-{ $class-description "A command map stores a group of related commands. The " { $snippet "commands" } " slot stores an association list mapping gestures to commands, and the " { $snippet "blurb" } " slot stores an optional one-line description string of this command map."
-$nl
-"Command maps are created by calling " { $link <command-map> } " or " { $link define-command-map } "." } ;
-
-HELP: commands
-{ $values { "class" "a class word" } { "hash" hashtable } }
-{ $description "Outputs a hashtable mapping command map names to " { $link command-map } " instances." } ;
-
-HELP: define-command-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "pairs" "a sequence of gesture/word pairs" } }
-{ $description
- "Defines a command map on the specified gadget class. The " { $snippet "specs" } " parameter is a sequence of pairs " { $snippet "{ gesture word }" } ". The words must be valid commands; see " { $link define-command } "."
-}
-{ $notes "Only one of " { $link define-command-map } " and " { $link set-gestures } " can be used on a given gadget class, since each word will overwrite the other word's definitions." } ;
-
-HELP: $command-map
-{ $values { "element" "a pair " { $snippet "{ class map }" } } }
-{ $description "Prints a command map, where the first element of the pair is a class word and the second is a command map name." } ;
-
-HELP: $command
-{ $values { "element" "a triple " { $snippet "{ class map command }" } } }
-{ $description "Prints the keyboard shortcut associated with " { $snippet "command" } " in the command map named " { $snippet "map" } " on the class " { $snippet "class" } "." } ;
-
-HELP: define-command
-{ $values { "word" word } { "hash" hashtable } }
-{ $description "Defines a command. The hashtable can contain the following keys:"
- { $list
- { { $link +nullary+ } " - if set to a true value, the word must have stack effect " { $snippet "( -- )" } "; otherwise it must have stack effect " { $snippet "( target -- )" } }
- { { $link +listener+ } " - if set to a true value, the command will run in the listener" }
- { { $link +description+ } " - can be set to a string description of the command" }
- }
-} ;
-
-HELP: command-string
-{ $values { "gesture" "a gesture" } { "command" "a command" } { "string" string } }
-{ $description "Outputs a string containing the command name followed by the gesture." }
-{ $examples
- { $example
- "USING: io ui.commands ui.gestures ;"
- "IN: scratchpad"
- ": com-my-command ;"
- "T{ key-down f { C+ } \"s\" } \\ com-my-command command-string write"
- "My Command (C+s)"
- }
-} ;
-
-ARTICLE: "ui-commands" "Commands"
-"Commands are an abstraction layered on top of gestures. Their main advantage is that they are identified by words and can be organized into " { $emphasis "command maps" } ". This allows easy construction of buttons and tool bars for invoking commands."
-{ $subsection define-command }
-"Command groups are defined on gadget classes:"
-{ $subsection define-command-map }
-"Commands can be introspected and invoked:"
-{ $subsection commands }
-{ $subsection command-map }
-{ $subsection invoke-command }
-"Gadgets for invoking commands are documented in " { $link "ui.gadgets.buttons" } "."
-$nl
-"When documenting gadgets, command documentation can be automatically generated:"
-{ $subsection $command-map }
-{ $subsection $command } ;
-
-ABOUT: "ui-commands"
+++ /dev/null
-IN: ui.commands.tests
-USING: ui.commands ui.gestures tools.test help.markup io
-io.streams.string ;
-
-[ "A+a" ] [ T{ key-down f { A+ } "a" } gesture>string ] unit-test
-[ "b" ] [ T{ key-down f f "b" } gesture>string ] unit-test
-[ "Press Button 2" ] [ T{ button-down f f 2 } gesture>string ] unit-test
-
-: com-test-1 ;
-
-\ com-test-1 H{ } define-command
-
-[ [ 3 com-test-1 ] ] [ 3 \ com-test-1 command-quot ] unit-test
-
-: com-test-2 ;
-
-\ com-test-2 H{ { +nullary+ t } } define-command
-
-[ [ com-test-2 ] ] [ 3 \ com-test-2 command-quot ] unit-test
-
-SYMBOL: testing
-
-testing "testing" "hey" {
- { T{ key-down f { C+ } "x" } com-test-1 }
-} define-command-map
-
-[ "C+x" ] [
- [
- { $command testing "testing" com-test-1 } print-element
- ] with-string-writer
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions kernel sequences strings
-math assocs words generic namespaces assocs quotations splitting
-ui.gestures unicode.case unicode.categories tr ;
-IN: ui.commands
-
-SYMBOL: +nullary+
-SYMBOL: +listener+
-SYMBOL: +description+
-
-PREDICATE: listener-command < word +listener+ word-prop ;
-
-GENERIC: invoke-command ( target command -- )
-
-GENERIC: command-name ( command -- str )
-
-TUPLE: command-map blurb commands ;
-
-GENERIC: command-description ( command -- str/f )
-
-GENERIC: command-word ( command -- word )
-
-: <command-map> ( blurb commands -- command-map )
- { } like \ command-map boa ;
-
-: commands ( class -- hash )
- dup "commands" word-prop [ ] [
- H{ } clone [ "commands" set-word-prop ] keep
- ] ?if ;
-
-: command-map ( group class -- command-map )
- commands at ;
-
-: command-gestures ( class -- hash )
- commands values [
- [
- commands>>
- [ drop ] assoc-filter
- [ [ invoke-command ] curry swap set ] assoc-each
- ] each
- ] H{ } make-assoc ;
-
-: update-gestures ( class -- )
- dup command-gestures "gestures" set-word-prop ;
-
-: define-command-map ( class group blurb pairs -- )
- <command-map>
- swap pick commands set-at
- update-gestures ;
-
-TR: convert-command-name "-" " " ;
-
-: (command-name) ( string -- newstring )
- convert-command-name >title ;
-
-M: word command-name ( word -- str )
- name>>
- "com-" ?head drop
- dup first Letter? [ rest ] unless
- (command-name) ;
-
-M: word command-description ( word -- str )
- +description+ word-prop ;
-
-: default-flags ( -- assoc )
- H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
-
-: define-command ( word hash -- )
- [ props>> ] [ default-flags swap assoc-union ] bi* update ;
-
-: command-quot ( target command -- quot )
- dup 1quotation swap +nullary+ word-prop
- [ nip ] [ curry ] if ;
-
-M: word invoke-command ( target command -- )
- command-quot call ;
-
-M: word command-word ;
-
-M: f invoke-command ( target command -- ) 2drop ;
-
-: command-string ( gesture command -- string )
- [
- command-name %
- gesture>string [ " (" % % ")" % ] when*
- ] "" make ;
+++ /dev/null
-UI command framework
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.syntax help.markup strings kernel alien opengl
-quotations ui.render io.styles freetype ;
-IN: ui.freetype
-
-HELP: freetype
-{ $values { "alien" alien } }
-{ $description "Outputs a native handle used by the FreeType library, initializing FreeType first if necessary." } ;
-
-HELP: open-fonts
-{ $var-description "Global variable. Hashtable mapping font descriptors to " { $link font } " instances." } ;
-
-{ font open-fonts open-font char-width string-width text-dim draw-string draw-text } related-words
-
-HELP: init-freetype
-{ $description "Initializes the FreeType library." }
-{ $notes "Do not call this word if you are using the UI." } ;
-
-HELP: font
-{ $class-description "A font which has been loaded by FreeType. Font instances have the following slots:"
- { $list
- { { $link font-ascent } ", " { $link font-descent } ", " { $link font-height } " - metrics." }
- { { $link font-handle } " - alien pointer to an " { $snippet "FT_Face" } "." }
- { { $link font-widths } " - sequence of character widths. Use " { $link char-width } " and " { $link string-width } " to compute string widths instead of reading this sequence directly." }
- }
-} ;
-
-HELP: close-freetype
-{ $description "Closes the FreeType library." }
-{ $notes "Do not call this word if you are using the UI." } ;
-
-HELP: open-face
-{ $values { "font" string } { "style" "one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } } { "face" "alien pointer to an " { $snippet "FT_Face" } } }
-{ $description "Loads a TrueType font with the requested logical font name and style." }
-{ $notes "This is a low-level word. Call " { $link open-font } " instead." } ;
-
-HELP: render-glyph
-{ $values { "font" font } { "char" "a non-negative integer" } { "bitmap" alien } }
-{ $description "Renders a character and outputs a pointer to the bitmap." } ;
-
-HELP: <char-sprite>
-{ $values { "open-font" font } { "char" "a non-negative integer" } { "sprite" sprite } }
-{ $description "Renders a character to an OpenGL texture and records a display list which draws a quad with this texture. This word allocates native resources which must be freed by " { $link free-sprites } "." } ;
-
-HELP: (draw-string)
-{ $values { "open-font" font } { "sprites" "a vector of " { $link sprite } " instances" } { "string" string } { "loc" "a pair of integers" } }
-{ $description "Draws a line of text." }
-{ $notes "This is a low-level word, UI code should use " { $link draw-string } " or " { $link draw-text } " instead." }
-{ $side-effects "sprites" } ;
-
-HELP: run-char-widths
-{ $values { "open-font" font } { "string" string } { "widths" "a sequence of integers" } }
-{ $description "Outputs a sequence of x co-ordinates of the midpoint of each character in the string." }
-{ $notes "This word is used to convert x offsets to document locations, for example when the user moves the caret by clicking the mouse." } ;
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors alien.c-types arrays io kernel libc
-math math.vectors namespaces opengl opengl.gl prettyprint assocs
-sequences io.files io.styles continuations freetype
-ui.gadgets.worlds ui.render ui.backend byte-arrays accessors
-locals ;
-
-IN: ui.freetype
-
-TUPLE: freetype-renderer ;
-
-SYMBOL: open-fonts
-
-: freetype-error ( n -- )
- zero? [ "FreeType error" throw ] unless ;
-
-DEFER: freetype
-
-: init-freetype ( -- )
- global [
- f <void*> dup FT_Init_FreeType freetype-error
- *void* \ freetype set
- H{ } clone open-fonts set
- ] bind ;
-
-: freetype ( -- alien )
- \ freetype get-global expired? [ init-freetype ] when
- \ freetype get-global ;
-
-TUPLE: font < identity-tuple
-ascent descent height handle widths ;
-
-M: font hashcode* drop font hashcode* ;
-
-: close-font ( font -- ) font-handle FT_Done_Face ;
-
-: close-freetype ( -- )
- global [
- open-fonts [ [ drop close-font ] assoc-each f ] change
- freetype [ FT_Done_FreeType f ] change
- ] bind ;
-
-M: freetype-renderer free-fonts ( world -- )
- [ handle>> select-gl-context ]
- [ fonts>> [ nip second free-sprites ] assoc-each ] bi ;
-
-: ttf-name ( font style -- name )
- 2array H{
- { { "monospace" plain } "VeraMono" }
- { { "monospace" bold } "VeraMoBd" }
- { { "monospace" bold-italic } "VeraMoBI" }
- { { "monospace" italic } "VeraMoIt" }
- { { "sans-serif" plain } "Vera" }
- { { "sans-serif" bold } "VeraBd" }
- { { "sans-serif" bold-italic } "VeraBI" }
- { { "sans-serif" italic } "VeraIt" }
- { { "serif" plain } "VeraSe" }
- { { "serif" bold } "VeraSeBd" }
- { { "serif" bold-italic } "VeraBI" }
- { { "serif" italic } "VeraIt" }
- } at ;
-
-: ttf-path ( name -- string )
- "resource:fonts/" swap ".ttf" 3append ;
-
-: (open-face) ( path length -- face )
- #! We use FT_New_Memory_Face, not FT_New_Face, since
- #! FT_New_Face only takes an ASCII path name and causes
- #! problems on localized versions of Windows
- [ freetype ] 2dip 0 f <void*> [
- FT_New_Memory_Face freetype-error
- ] keep *void* ;
-
-: open-face ( font style -- face )
- ttf-name ttf-path malloc-file-contents (open-face) ;
-
-SYMBOL: dpi
-
-72 dpi set-global
-
-: ft-floor -6 shift ; inline
-
-: ft-ceil 63 + -64 bitand -6 shift ; inline
-
-: font-units>pixels ( n font -- n )
- face-size face-size-y-scale FT_MulFix ;
-
-: init-ascent ( font face -- font )
- dup face-y-max swap font-units>pixels >>ascent ; inline
-
-: init-descent ( font face -- font )
- dup face-y-min swap font-units>pixels >>descent ; inline
-
-: init-font ( font -- font )
- dup handle>> init-ascent
- dup handle>> init-descent
- dup [ ascent>> ] [ descent>> ] bi - ft-ceil >>height ; inline
-
-: set-char-size ( handle size -- )
- 0 swap 6 shift dpi get-global dup FT_Set_Char_Size freetype-error ;
-
-: <font> ( handle -- font )
- font new
- H{ } clone >>widths
- over first2 open-face >>handle
- dup handle>> rot third set-char-size
- init-font ;
-
-M: freetype-renderer open-font ( font -- open-font )
- freetype drop open-fonts get [ <font> ] cache ;
-
-: load-glyph ( font char -- glyph )
- >r font-handle dup r> 0 FT_Load_Char
- freetype-error face-glyph ;
-
-: char-width ( open-font char -- w )
- over font-widths [
- dupd load-glyph glyph-hori-advance ft-ceil
- ] cache nip ;
-
-M: freetype-renderer string-width ( open-font string -- w )
- 0 -rot [ char-width + ] with each ;
-
-M: freetype-renderer string-height ( open-font string -- h )
- drop font-height ;
-
-: glyph-size ( glyph -- dim )
- dup glyph-hori-advance ft-ceil
- swap glyph-height ft-ceil 2array ;
-
-: render-glyph ( font char -- bitmap )
- load-glyph dup
- FT_RENDER_MODE_NORMAL FT_Render_Glyph freetype-error ;
-
-:: copy-pixel ( i j bitmap texture -- i j )
- 255 j texture set-char-nth
- i bitmap char-nth j 1 + texture set-char-nth
- i 1 + j 2 + ; inline
-
-:: (copy-row) ( i j bitmap texture end -- )
- i end < [
- i j bitmap texture copy-pixel
- bitmap texture end (copy-row)
- ] when ; inline recursive
-
-:: copy-row ( i j bitmap texture width width2 -- i j )
- i j bitmap texture i width + (copy-row)
- i width +
- j width2 + ; inline
-
-:: copy-bitmap ( glyph texture -- )
- [let* | bitmap [ glyph glyph-bitmap-buffer ]
- rows [ glyph glyph-bitmap-rows ]
- width [ glyph glyph-bitmap-width ]
- width2 [ width next-power-of-2 2 * ] |
- 0 0
- rows [ bitmap texture width width2 copy-row ] times
- 2drop
- ] ;
-
-: bitmap>texture ( glyph sprite -- id )
- tuck sprite-size2 * 2 * [
- [ copy-bitmap ] keep gray-texture
- ] with-malloc ;
-
-: glyph-texture-loc ( glyph font -- loc )
- over glyph-hori-bearing-x ft-floor -rot
- font-ascent swap glyph-hori-bearing-y - ft-floor 2array ;
-
-: glyph-texture-size ( glyph -- dim )
- [ glyph-bitmap-width next-power-of-2 ]
- [ glyph-bitmap-rows next-power-of-2 ]
- bi 2array ;
-
-: <char-sprite> ( open-font char -- sprite )
- over >r render-glyph dup r> glyph-texture-loc
- over glyph-size pick glyph-texture-size <sprite>
- [ bitmap>texture ] keep [ init-sprite ] keep ;
-
-:: char-sprite ( open-font sprites char -- sprite )
- char sprites [ open-font swap <char-sprite> ] cache ;
-
-: draw-char ( open-font sprites char loc -- )
- GL_MODELVIEW [
- 0 0 glTranslated
- char-sprite sprite-dlist glCallList
- ] do-matrix ;
-
-: char-widths ( open-font string -- widths )
- [ char-width ] with { } map-as ;
-
-: scan-sums ( seq -- seq' )
- 0 [ + ] accumulate nip ;
-
-:: (draw-string) ( open-font sprites string loc -- )
- GL_TEXTURE_2D [
- loc [
- string open-font string char-widths scan-sums [
- [ open-font sprites ] 2dip draw-char
- ] 2each
- ] with-translation
- ] do-enabled ;
-
-: font-sprites ( font world -- open-font sprites )
- world-fonts [ open-font H{ } clone 2array ] cache first2 ;
-
-M: freetype-renderer draw-string ( font string loc -- )
- >r >r world get font-sprites r> r> (draw-string) ;
-
-: run-char-widths ( open-font string -- widths )
- char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
-
-M: freetype-renderer x>offset ( x open-font string -- n )
- dup >r run-char-widths [ <= ] with find drop
- [ r> drop ] [ r> length ] if* ;
-
-T{ freetype-renderer } font-renderer set-global
+++ /dev/null
-UI text rendering implementation based on FreeType
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets models ;
-IN: ui.gadgets.books
-
-HELP: book
-{ $class-description "A book is a control containing one or more children. The " { $link control-value } " is the index of exactly one child to be visible at any one time, the rest being hidden by having their " { $link gadget-visible? } " slots set to " { $link f } ". The sole visible child assumes the dimensions of the book gadget."
-$nl
-"Books are created by calling " { $link <book> } "." } ;
-
-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 " } ;
-
-ARTICLE: "ui-book-layout" "Book layouts"
-"Books can contain any number of children, and display one child at a time."
-{ $subsection book }
-{ $subsection <book> } ;
-
-ABOUT: "ui-book-layout"
+++ /dev/null
-IN: ui.gadgets.books.tests
-USING: tools.test ui.gadgets.books ;
-
-\ <book> must-infer
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
-IN: ui.gadgets.books
-
-TUPLE: book < gadget ;
-
-: hide-all ( book -- ) gadget-children [ hide-gadget ] each ;
-
-: current-page ( book -- gadget ) [ control-value ] keep nth-gadget ;
-
-M: book model-changed ( model book -- )
- nip
- dup hide-all
- dup current-page show-gadget
- relayout ;
-
-: new-book ( pages model class -- book )
- new-gadget
- swap >>model
- swap add-gadgets ; inline
-
-: <book> ( pages model -- book ) book new-book ;
-
-M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
-
-M: book layout* ( book -- )
- [ dim>> ] [ children>> ] bi [ (>>dim) ] with each ;
-
-M: book focusable-child* ( book -- child/t ) current-page ;
+++ /dev/null
-Book gadget displays one child at a time
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets math ;
-IN: ui.gadgets.borders
-
-HELP: border
-{ $class-description "A border gadget contains a single child and centers it, with a fixed-width border. Borders are created by calling " { $link <border> } "." } ;
-
-HELP: <border>
-{ $values { "child" gadget } { "gap" integer } { "border" "a new " { $link border } } }
-{ $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."
-{ $subsection border }
-{ $subsection <border> } ;
-
-ABOUT: "ui.gadgets.borders"
+++ /dev/null
-IN: ui.gadgets.borders.tests
-USING: tools.test accessors namespaces kernel
-ui.gadgets ui.gadgets.borders math.geometry.rect ;
-
-[ { 110 210 } ] [ <gadget> { 100 200 } >>dim 5 <border> pref-dim ] unit-test
-
-[ ] [ <gadget> { 100 200 } >>dim "g" set ] unit-test
-
-[ ] [ "g" get 0 <border> { 100 200 } >>dim "b" set ] unit-test
-
-[ T{ rect f { 0 0 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
-
-[ ] [ "g" get 5 <border> { 210 210 } >>dim "b" set ] unit-test
-
-[ T{ rect f { 55 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
-
-[ ] [ "b" get { 0 0 } >>align drop ] unit-test
-
-[ { 5 5 } ] [ "b" get { 100 200 } border-loc ] unit-test
-
-[ T{ rect f { 5 5 } { 100 200 } } ] [ "b" get border-child-rect ] unit-test
-
-[ ] [ "b" get { 1 1 } >>fill drop ] unit-test
-
-[ T{ rect f { 5 5 } { 200 200 } } ] [ "b" get border-child-rect ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gadgets kernel math
-namespaces vectors sequences math.vectors math.geometry.rect ;
-IN: ui.gadgets.borders
-
-TUPLE: border < gadget
-{ size initial: { 0 0 } }
-{ fill initial: { 0 0 } }
-{ align initial: { 1/2 1/2 } } ;
-
-: new-border ( child class -- border )
- new-gadget [ swap add-gadget drop ] keep ; inline
-
-: <border> ( child gap -- border )
- swap border new-border
- swap dup 2array >>size ;
-
-M: border pref-dim*
- [ size>> 2 v*n ] keep
- gadget-child pref-dim v+ ;
-
-: border-major-dim ( border -- dim )
- [ dim>> ] [ size>> 2 v*n ] bi v- ;
-
-: border-minor-dim ( border -- dim )
- gadget-child pref-dim ;
-
-: scale ( a b s -- c )
- tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ;
-
-: border-dim ( border -- dim )
- [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
-
-: border-loc ( border dim -- loc )
- [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
- v- v* v+ [ >fixnum ] map ;
-
-: border-child-rect ( border -- rect )
- dup border-dim [ border-loc ] keep <rect> ;
-
-M: border layout*
- dup border-child-rect swap gadget-child
- over loc>> over set-rect-loc
- swap dim>> swap (>>dim) ;
-
-M: border focusable-child*
- gadget-child ;
+++ /dev/null
-Border gadget adds padding around a child
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets ui.gadgets.labels
-ui.render kernel models classes ;
-IN: ui.gadgets.buttons
-
-HELP: button
-{ $class-description "A button is a " { $link gadget } " which responds to mouse clicks by invoking a quotation."
-$nl
-"A button's appearance can vary depending on the state of the mouse button if the " { $link gadget-interior } " or " { $link gadget-boundary } " slots are set to instances of " { $link button-paint } "."
-$nl
-"A button can be selected, which is distinct from being pressed. This state is held in the " { $link button-selected? } " slot, and is used by the " { $link <toggle-buttons> } " word to construct a row of buttons for choosing among several alternatives." } ;
-
-HELP: <button>
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" "a new " { $link button } } }
-{ $description "Creates a new " { $link button } " which calls the quotation when clicked. The given gadget becomes the button's only child." } ;
-
-HELP: <roll-button>
-{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
-{ $description "Creates a new " { $link button } " which is displayed with a solid border when it is under the mouse, informing the user that the gadget is clickable." } ;
-
-HELP: <bevel-button>
-{ $values { "label" "a label specifier" } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" button } }
-{ $description "Creates a new " { $link button } " with a shaded border which is always visible. The button appearance changes in response to mouse gestures using a " { $link button-paint } "." } ;
-
-HELP: <repeat-button>
-{ $values { "label" object } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } { "button" repeat-button } }
-{ $description "Creates a new " { $link button } " derived from a " { $link <bevel-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ;
-
-HELP: button-paint
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
- { $list
- { { $link button-paint-plain } " - the button is inactive" }
- { { $link button-paint-rollover } " - the button is under the mouse" }
- { { $link button-paint-pressed } " - the button is under the mouse and a mouse button is held down" }
- { { $link button-paint-selected } " - the button is selected (see " { $link <toggle-buttons> } }
- }
-"The " { $link <roll-button> } " and " { $link <bevel-button> } " words create " { $link button } " instances with specific " { $link button-paint } "." } ;
-
-HELP: <toggle-button>
-{ $values { "model" model } { "value" object } { "label" "a label specifier" } { "gadget" gadget } }
-{ $description
- "Creates a " { $link <bevel-button> } " which sets the model's value to " { $snippet "value" } " when pressed. After being pressed, the button becomes selected until the value of the model changes again."
-}
-{ $notes "Typically a row of radio controls should be built together using " { $link <toggle-buttons> } "." } ;
-
-HELP: <toggle-buttons>
-{ $values { "model" model } { "assoc" "an association list mapping labels to objects" } { "gadget" gadget } }
-{ $description "Creates a row of labelled " { $link <toggle-button> } " gadgets which change the value of the model." } ;
-
-HELP: <command-button>
-{ $values { "target" object } { "gesture" "a gesture" } { "command" "a command" } { "button" "a new " { $link button } } }
-{ $description "Creates a " { $link <bevel-button> } " which invokes the command on " { $snippet "target" } " when clicked." } ;
-
-HELP: <toolbar>
-{ $values { "target" object } { "toolbar" gadget } }
-{ $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."
-{ $subsection button }
-"There are many ways to create a new button:"
-{ $subsection <button> }
-{ $subsection <roll-button> }
-{ $subsection <bevel-button> }
-{ $subsection <repeat-button> }
-"Gadgets for invoking commands:"
-{ $subsection <command-button> }
-{ $subsection <toolbar> }
-"A radio box is a row of buttons for choosing amongst several distinct possibilities:"
-{ $subsection <toggle-buttons> }
-"Button appearance can be customized:"
-{ $subsection button-paint }
-"Button constructors take " { $emphasis "label specifiers" } " as input. A label specifier is either a string, an array of strings, a gadget or " { $link f } "."
-{ $see-also <command-button> "ui-commands" } ;
+++ /dev/null
-IN: ui.gadgets.buttons.tests
-USING: ui.commands ui.gadgets.buttons ui.gadgets.labels
-ui.gadgets tools.test namespaces sequences kernel models ;
-
-TUPLE: foo-gadget ;
-
-: com-foo-a ;
-
-: com-foo-b ;
-
-\ foo-gadget "toolbar" f {
- { f com-foo-a }
- { f com-foo-b }
-} define-command-map
-
-T{ foo-gadget } <toolbar> "t" set
-
-[ 2 ] [ "t" get gadget-children length ] unit-test
-[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test
-
-[ ] [
- 2 <model> {
- { 0 "atheist" }
- { 1 "christian" }
- { 2 "muslim" }
- { 3 "jewish" }
- } <radio-buttons> "religion" set
-] unit-test
-
-\ <radio-buttons> must-infer
-
-\ <toggle-buttons> must-infer
-
-\ <checkbox> must-infer
-
-[ 0 ] [
- "religion" get gadget-child radio-control-value
-] unit-test
-
-[ 2 ] [
- "religion" get gadget-child control-value
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math models namespaces sequences
- strings quotations assocs combinators classes colors
- classes.tuple opengl math.vectors
- ui.commands ui.gadgets ui.gadgets.borders
- ui.gadgets.labels ui.gadgets.theme
- ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
- ui.render math.geometry.rect ;
-
-IN: ui.gadgets.buttons
-
-TUPLE: button < border pressed? selected? quot ;
-
-: buttons-down? ( -- ? )
- hand-buttons get-global empty? not ;
-
-: button-rollover? ( button -- ? )
- hand-gadget get-global child? ;
-
-: mouse-clicked? ( gadget -- ? )
- hand-clicked get-global child? ;
-
-: button-update ( button -- )
- dup mouse-clicked?
- over button-rollover? and
- buttons-down? and
- over set-button-pressed?
- relayout-1 ;
-
-: if-clicked ( button quot -- )
- >r dup button-update dup button-rollover? r> [ drop ] if ;
-
-: button-clicked ( button -- )
- dup button-quot if-clicked ;
-
-button H{
- { T{ button-up } [ button-clicked ] }
- { T{ button-down } [ button-update ] }
- { T{ mouse-leave } [ button-update ] }
- { T{ mouse-enter } [ button-update ] }
-} set-gestures
-
-: new-button ( label quot class -- button )
- [ swap >label ] dip new-border swap >>quot ; inline
-
-: <button> ( label quot -- button )
- button new-button ;
-
-TUPLE: button-paint plain rollover pressed selected ;
-
-C: <button-paint> button-paint
-
-: find-button ( gadget -- button )
- [ [ button? ] is? ] find-parent ;
-
-: button-paint ( button paint -- button paint )
- over find-button {
- { [ dup pressed?>> ] [ drop pressed>> ] }
- { [ dup selected?>> ] [ drop selected>> ] }
- { [ dup button-rollover? ] [ drop rollover>> ] }
- [ drop plain>> ]
- } cond ;
-
-M: button-paint draw-interior
- button-paint draw-interior ;
-
-M: button-paint draw-boundary
- button-paint draw-boundary ;
-
-: roll-button-theme ( button -- button )
- f black <solid> dup f <button-paint> >>boundary
- { 0 1/2 } >>align ; inline
-
-: <roll-button> ( label quot -- button )
- <button> roll-button-theme ;
-
-: <bevel-button-paint> ( -- paint )
- plain-gradient
- rollover-gradient
- pressed-gradient
- selected-gradient
- <button-paint> ;
-
-: bevel-button-theme ( gadget -- gadget )
- <bevel-button-paint> >>interior
- { 5 5 } >>size
- faint-boundary ; inline
-
-: <bevel-button> ( label quot -- button )
- <button> bevel-button-theme ;
-
-TUPLE: repeat-button < button ;
-
-repeat-button H{
- { T{ drag } [ button-clicked ] }
-} set-gestures
-
-: <repeat-button> ( label quot -- button )
- #! Button that calls the quotation every 100ms as long as
- #! the mouse is held down.
- repeat-button new-button bevel-button-theme ;
-
-TUPLE: checkmark-paint color ;
-
-C: <checkmark-paint> checkmark-paint
-
-M: checkmark-paint draw-interior
- checkmark-paint-color set-color
- origin get [
- rect-dim
- { 0 0 } over gl-line
- dup { 0 1 } v* swap { 1 0 } v* gl-line
- ] with-translation ;
-
-: checkmark-theme ( gadget -- )
- f
- f
- black <solid>
- black <checkmark-paint>
- <button-paint>
- over set-gadget-interior
- black <solid>
- swap set-gadget-boundary ;
-
-: <checkmark> ( -- gadget )
- <gadget>
- dup checkmark-theme
- { 14 14 } over (>>dim) ;
-
-: toggle-model ( model -- )
- [ not ] change-model ;
-
-: checkbox-theme ( gadget -- gadget )
- f >>interior
- { 5 5 } >>gap
- 1/2 >>align ; inline
-
-TUPLE: checkbox < button ;
-
-: <checkbox> ( model label -- checkbox )
- <checkmark> label-on-right checkbox-theme
- [ model>> toggle-model ]
- checkbox new-button
- swap >>model ;
-
-M: checkbox model-changed
- swap model-value over set-button-selected? relayout-1 ;
-
-TUPLE: radio-paint color ;
-
-C: <radio-paint> radio-paint
-
-M: radio-paint draw-interior
- radio-paint-color set-color
- origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
-
-M: radio-paint draw-boundary
- radio-paint-color set-color
- origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
-
-: radio-knob-theme ( gadget -- )
- f
- f
- black <radio-paint>
- black <radio-paint>
- <button-paint>
- over set-gadget-interior
- black <radio-paint>
- swap set-gadget-boundary ;
-
-: <radio-knob> ( -- gadget )
- <gadget>
- dup radio-knob-theme
- { 16 16 } over (>>dim) ;
-
-TUPLE: radio-control < button value ;
-
-: <radio-control> ( value model label -- control )
- [ [ value>> ] keep set-control-value ]
- radio-control new-button
- swap >>model
- swap >>value ; inline
-
-M: radio-control model-changed
- swap model-value
- over radio-control-value =
- over set-button-selected?
- relayout-1 ;
-
-: <radio-controls> ( parent model assoc quot -- parent )
- #! quot has stack effect ( value model label -- )
- swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
-
-: radio-button-theme ( gadget -- gadget )
- { 5 5 } >>gap
- 1/2 >>align ; inline
-
-: <radio-button> ( value model label -- gadget )
- <radio-knob> label-on-right radio-button-theme <radio-control> ;
-
-: <radio-buttons> ( model assoc -- gadget )
- <filled-pile>
- -rot
- [ <radio-button> ] <radio-controls>
- { 5 5 } >>gap ;
-
-: <toggle-button> ( value model label -- gadget )
- <radio-control> bevel-button-theme ;
-
-: <toggle-buttons> ( model assoc -- gadget )
- <shelf>
- -rot
- [ <toggle-button> ] <radio-controls> ;
-
-: command-button-quot ( target command -- quot )
- [ invoke-command drop ] 2curry ;
-
-: <command-button> ( target gesture command -- button )
- [ command-string ] keep
- swapd
- command-button-quot
- <bevel-button> ;
-
-: <toolbar> ( target -- toolbar )
- <shelf>
- swap
- "toolbar" over class command-map commands>> swap
- [ -rot <command-button> add-gadget ] curry assoc-each ;
+++ /dev/null
-Button gadgets invoke commands when clicked
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib
-ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
-classes.tuple colors ;
-IN: ui.gadgets.canvas
-
-TUPLE: canvas < gadget dlist ;
-
-: <canvas> ( -- canvas )
- canvas new-gadget
- black solid-interior ;
-
-: delete-canvas-dlist ( canvas -- )
- dup find-gl-context
- dup canvas-dlist [ delete-dlist ] when*
- f swap set-canvas-dlist ;
-
-: make-canvas-dlist ( canvas quot -- dlist )
- over >r GL_COMPILE swap make-dlist dup r>
- set-canvas-dlist ;
-
-: cache-canvas-dlist ( canvas quot -- dlist )
- over canvas-dlist dup
- [ 2nip ] [ drop make-canvas-dlist ] if ; inline
-
-: draw-canvas ( canvas quot -- )
- origin get [
- cache-canvas-dlist glCallList
- ] with-translation ; inline
-
-M: canvas ungraft* delete-canvas-dlist ;
+++ /dev/null
-
-USING: kernel combinators sequences opengl.gl
- ui.render ui.gadgets ui.gadgets.slate
- accessors ;
-
-IN: ui.gadgets.cartesian
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;
-
-: init-cartesian ( cartesian -- cartesian )
- init-slate
- -10 >>x-min
- 10 >>x-max
- -10 >>y-min
- 10 >>y-max
- -1 >>z-min
- 1 >>z-max ;
-
-: <cartesian> ( -- cartesian ) cartesian new init-cartesian ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: cartesian establish-coordinate-system ( cartesian -- cartesian )
- dup
- {
- [ x-min>> ] [ x-max>> ]
- [ y-min>> ] [ y-max>> ]
- [ z-min>> ] [ z-max>> ]
- }
- cleave
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ;
-: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ;
-: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: documents help.markup help.syntax ui.gadgets
-ui.gadgets.scrollers models strings ui.commands ;
-IN: ui.gadgets.editors
-
-HELP: editor
-{ $class-description "An editor is a control for editing a multi-line passage of text stored in a " { $link document } " model. Editors are crated by calling " { $link <editor> } "."
-$nl
-"Editors have the following slots:"
-{ $list
- { { $link editor-font } " - a font specifier." }
- { { $link editor-color } " - text color specifier." }
- { { $link editor-caret-color } " - caret color specifier." }
- { { $link editor-selection-color } " - selection background color specifier." }
- { { $link editor-caret } " - a model storing a line/column pair." }
- { { $link editor-mark } " - a model storing a line/column pair. If there is no selection, the mark is equal to the caret, otherwise the mark is located at the opposite end of the selection from the caret." }
- { { $link editor-focused? } " - a boolean." }
-} } ;
-
-HELP: <editor>
-{ $values { "editor" "a new " { $link editor } } }
-{ $description "Creates a new " { $link editor } " with an empty document." } ;
-
-HELP: editor-caret ( editor -- caret )
-{ $values { "editor" editor } { "caret" model } }
-{ $description "Outputs a " { $link model } " holding the current caret location." } ;
-
-{ editor-caret editor-caret* editor-mark editor-mark* } related-words
-
-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 ( editor -- mark )
-{ $values { "editor" editor } { "mark" model } }
-{ $description "Outputs a " { $link model } " holding the current mark location." } ;
-
-HELP: editor-mark*
-{ $values { "editor" editor } { "loc" "a pair of integers" } }
-{ $description "Outputs the current mark location as a line/column number pair." } ;
-
-HELP: change-caret
-{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
-{ $description "Applies a quotation to the current caret location and moves the caret to the location output by the quotation." } ;
-
-{ change-caret change-caret&mark mark>caret } related-words
-
-HELP: mark>caret
-{ $values { "editor" editor } }
-{ $description "Moves the mark to the caret location, effectively deselecting any selected text." } ;
-
-HELP: change-caret&mark
-{ $values { "editor" editor } { "quot" "a quotation with stack effect " { $snippet "( loc -- newloc )" } } }
-{ $description "Applies a quotation to the current caret location and moves the caret and the mark to the location output by the quotation." } ;
-
-HELP: point>loc
-{ $values { "point" "a pair of integers" } { "editor" editor } { "loc" "a pair of integers" } }
-{ $description "Converts a point to a line/column number pair." } ;
-
-HELP: scroll>caret
-{ $values { "editor" editor } }
-{ $description "Ensures that the caret becomes visible in a " { $link scroller } " containing the editor. Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
-
-HELP: remove-selection
-{ $values { "editor" editor } }
-{ $description "Removes currently selected text from the editor's " { $link document } "." } ;
-
-HELP: editor-string
-{ $values { "editor" editor } { "string" string } }
-{ $description "Outputs the contents of the editor's " { $link document } " as a string. Lines are separated by " { $snippet "\\n" } "." } ;
-
-HELP: set-editor-string
-{ $values { "string" string } { "editor" editor } }
-{ $description "Sets the contents of the editor's " { $link document } " to a string, which may use either " { $snippet "\\n" } ", " { $snippet "\\r\\n" } " or " { $snippet "\\r" } " line separators." } ;
-
-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-caret* }
-{ $subsection editor-mark }
-{ $subsection editor-mark* }
-{ $subsection change-caret }
-{ $subsection change-caret&mark }
-{ $subsection mark>caret }
-"Getting the selected text:"
-{ $subsection gadget-selection? }
-{ $subsection gadget-selection }
-"Removing selected text:"
-{ $subsection remove-selection }
-"Scrolling to the caret location:"
-{ $subsection scroll>caret }
-"Use " { $link user-input* } " to change selected text." ;
-
-ARTICLE: "gadgets-editors" "Editor gadgets"
-"An editor edits a multi-line passage of text."
-{ $command-map editor "general" }
-{ $command-map editor "caret-motion" }
-{ $command-map editor "selection" }
-{ $heading "Editor words" }
-{ $subsection editor }
-{ $subsection <editor> }
-{ $subsection editor-string }
-{ $subsection set-editor-string }
-{ $subsection "gadgets-editors-selection" }
-{ $subsection "documents" }
-{ $subsection "document-locs-elts" } ;
-
-ABOUT: "gadgets-editors"
+++ /dev/null
-USING: accessors ui.gadgets.editors tools.test kernel io
-io.streams.plain definitions namespaces ui.gadgets
-ui.gadgets.grids prettyprint documents ui.gestures tools.test.ui
-models ;
-
-[ "foo bar" ] [
- <editor> "editor" set
- "editor" get [
- "foo bar" "editor" get set-editor-string
- "editor" get T{ one-line-elt } select-elt
- "editor" get gadget-selection
- ] with-grafted-gadget
-] unit-test
-
-[ "baz quux" ] [
- <editor> "editor" set
- "editor" get [
- "foo bar\nbaz quux" "editor" get set-editor-string
- "editor" get T{ 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
- 4 hand-click# set
- "editor" get position-caret
- ] with-grafted-gadget
-] unit-test
-
-[ "bar" ] [
- <editor> "editor" set
- "editor" get [
- "bar\nbaz quux" "editor" get set-editor-string
- { 0 3 } "editor" get editor-caret set-model
- "editor" get select-word
- "editor" get gadget-selection
- ] with-grafted-gadget
-] unit-test
-
-\ <editor> must-infer
-
-"hello" <model> <field> "field" set
-
-"field" get [
- [ "hello" ] [ "field" get field-model>> model-value ] unit-test
-] with-grafted-gadget
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays documents io kernel math models
-namespaces opengl opengl.gl sequences strings io.styles
-math.vectors sorting colors combinators assocs math.order
-ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
-math.geometry.rect ;
-IN: ui.gadgets.editors
-
-TUPLE: editor < gadget
-font color caret-color selection-color
-caret mark
-focused? ;
-
-: <loc> ( -- loc ) { 0 0 } <model> ;
-
-: init-editor-locs ( editor -- editor )
- <loc> >>caret
- <loc> >>mark ; inline
-
-: editor-theme ( editor -- editor )
- black >>color
- red >>caret-color
- selection-color >>selection-color
- monospace-font >>font ; inline
-
-: new-editor ( class -- editor )
- new-gadget
- <document> >>model
- init-editor-locs
- editor-theme ; inline
-
-: <editor> ( -- editor )
- editor new-editor ;
-
-: activate-editor-model ( editor model -- )
- 2dup add-connection
- dup activate-model
- swap gadget-model add-loc ;
-
-: deactivate-editor-model ( editor model -- )
- 2dup remove-connection
- dup deactivate-model
- swap gadget-model remove-loc ;
-
-M: editor graft*
- dup
- dup editor-caret activate-editor-model
- dup editor-mark activate-editor-model ;
-
-M: editor ungraft*
- dup
- dup editor-caret deactivate-editor-model
- dup editor-mark deactivate-editor-model ;
-
-: editor-caret* ( editor -- loc ) editor-caret model-value ;
-
-: editor-mark* ( editor -- loc ) editor-mark model-value ;
-
-: set-caret ( loc editor -- )
- [ gadget-model validate-loc ] keep
- editor-caret set-model ;
-
-: change-caret ( editor quot -- )
- over >r >r dup editor-caret* swap gadget-model r> call r>
- set-caret ; inline
-
-: mark>caret ( editor -- )
- dup editor-caret* swap editor-mark set-model ;
-
-: change-caret&mark ( editor quot -- )
- over >r change-caret r> mark>caret ; inline
-
-: editor-line ( n editor -- str ) control-value nth ;
-
-: editor-font* ( editor -- font ) editor-font open-font ;
-
-: line-height ( editor -- n )
- editor-font* "" string-height ;
-
-: y>line ( y editor -- line# )
- [ line-height / >fixnum ] keep gadget-model validate-line ;
-
-: point>loc ( point editor -- loc )
- [
- >r first2 r> tuck y>line dup ,
- >r dup editor-font* r>
- rot editor-line x>offset ,
- ] { } make ;
-
-: clicked-loc ( editor -- loc )
- [ hand-rel ] keep point>loc ;
-
-: click-loc ( editor model -- )
- >r clicked-loc r> set-model ;
-
-: focus-editor ( editor -- )
- t over set-editor-focused? relayout-1 ;
-
-: unfocus-editor ( editor -- )
- f over set-editor-focused? relayout-1 ;
-
-: (offset>x) ( font col# str -- x )
- swap head-slice string-width ;
-
-: offset>x ( col# line# editor -- x )
- [ editor-line ] keep editor-font* -rot (offset>x) ;
-
-: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
-
-: line>y ( lines# editor -- y )
- line-height * ;
-
-: caret-loc ( editor -- loc )
- [ editor-caret* ] keep 2dup loc>x
- rot first rot line>y 2array ;
-
-: caret-dim ( editor -- dim )
- line-height 0 swap 2array ;
-
-: scroll>caret ( editor -- )
- dup gadget-graft-state second [
- dup caret-loc over caret-dim { 1 0 } v+ <rect>
- over scroll>rect
- ] when drop ;
-
-: draw-caret ( -- )
- editor get editor-focused? [
- editor get
- dup editor-caret-color set-color
- dup caret-loc origin get v+
- swap caret-dim over v+
- [ { 0.5 -0.5 } v+ ] bi@ gl-line
- ] when ;
-
-: line-translation ( n -- loc )
- editor get line-height * 0.0 swap 2array ;
-
-: translate-lines ( n -- )
- line-translation gl-translate ;
-
-: draw-line ( editor str -- )
- >r editor-font r> { 0 0 } draw-string ;
-
-: first-visible-line ( editor -- n )
- clip get rect-loc second origin get second -
- swap y>line ;
-
-: last-visible-line ( editor -- n )
- clip get rect-extent nip second origin get second -
- swap y>line 1+ ;
-
-: with-editor ( editor quot -- )
- [
- swap
- dup first-visible-line \ first-visible-line set
- dup last-visible-line \ last-visible-line set
- dup gadget-model document set
- editor set
- call
- ] with-scope ; inline
-
-: visible-lines ( editor -- seq )
- \ first-visible-line get
- \ last-visible-line get
- rot control-value <slice> ;
-
-: with-editor-translation ( n quot -- )
- >r line-translation origin get v+ r> with-translation ;
- inline
-
-: draw-lines ( -- )
- \ first-visible-line get [
- editor get dup editor-color set-color
- dup visible-lines
- [ draw-line 1 translate-lines ] with each
- ] with-editor-translation ;
-
-: selection-start/end ( editor -- start end )
- dup editor-mark* swap editor-caret* sort-pair ;
-
-: (draw-selection) ( x1 x2 -- )
- 2dup = [ 2 + ] when
- 0.0 swap editor get line-height glRectd ;
-
-: draw-selected-line ( start end n -- )
- [ start/end-on-line ] keep tuck
- >r >r editor get offset>x r> r>
- editor get offset>x
- (draw-selection) ;
-
-: draw-selection ( -- )
- editor get editor-selection-color set-color
- editor get selection-start/end
- over first [
- 2dup [
- >r 2dup r> draw-selected-line
- 1 translate-lines
- ] each-line 2drop
- ] with-editor-translation ;
-
-M: editor draw-gadget*
- [ draw-selection draw-lines draw-caret ] with-editor ;
-
-M: editor pref-dim*
- dup editor-font* swap control-value text-dim ;
-
-: contents-changed ( model editor -- )
- swap
- over caret>> [ over validate-loc ] (change-model)
- over mark>> [ over validate-loc ] (change-model)
- drop relayout ;
-
-: caret/mark-changed ( model editor -- )
- nip [ relayout-1 ] [ scroll>caret ] bi ;
-
-M: editor model-changed
- {
- { [ 2dup model>> eq? ] [ contents-changed ] }
- { [ 2dup caret>> eq? ] [ caret/mark-changed ] }
- { [ 2dup mark>> eq? ] [ caret/mark-changed ] }
- } cond ;
-
-M: editor gadget-selection?
- selection-start/end = not ;
-
-M: editor gadget-selection
- [ selection-start/end ] keep gadget-model doc-range ;
-
-: remove-selection ( editor -- )
- [ selection-start/end ] keep gadget-model remove-doc-range ;
-
-M: editor user-input*
- [ selection-start/end ] keep gadget-model set-doc-range t ;
-
-: editor-string ( editor -- string )
- gadget-model doc-string ;
-
-: set-editor-string ( string editor -- )
- gadget-model set-doc-string ;
-
-M: editor gadget-text* editor-string % ;
-
-: extend-selection ( editor -- )
- dup request-focus dup editor-caret click-loc ;
-
-: mouse-elt ( -- element )
- hand-click# get {
- { 1 T{ one-char-elt } }
- { 2 T{ one-word-elt } }
- } at T{ one-line-elt } or ;
-
-: drag-direction? ( loc editor -- ? )
- editor-mark* before? ;
-
-: drag-selection-caret ( loc editor element -- loc )
- >r [ drag-direction? ] 2keep
- gadget-model
- r> prev/next-elt ? ;
-
-: drag-selection-mark ( loc editor element -- loc )
- >r [ drag-direction? not ] 2keep
- nip dup editor-mark* swap gadget-model
- r> prev/next-elt ? ;
-
-: drag-caret&mark ( editor -- caret mark )
- dup clicked-loc swap mouse-elt
- [ drag-selection-caret ] 3keep
- drag-selection-mark ;
-
-: drag-selection ( editor -- )
- dup drag-caret&mark
- pick editor-mark set-model
- swap editor-caret set-model ;
-
-: editor-cut ( editor clipboard -- )
- dupd gadget-copy remove-selection ;
-
-: delete/backspace ( elt editor quot -- )
- over gadget-selection? [
- drop nip remove-selection
- ] [
- over >r >r dup editor-caret* swap gadget-model
- r> call r> gadget-model remove-doc-range
- ] if ; inline
-
-: editor-delete ( editor elt -- )
- swap [ over >r rot next-elt r> swap ] delete/backspace ;
-
-: editor-backspace ( editor elt -- )
- swap [ over >r rot prev-elt r> ] delete/backspace ;
-
-: editor-select-prev ( editor elt -- )
- swap [ rot prev-elt ] change-caret ;
-
-: editor-prev ( editor elt -- )
- dupd editor-select-prev mark>caret ;
-
-: editor-select-next ( editor elt -- )
- swap [ rot next-elt ] change-caret ;
-
-: editor-next ( editor elt -- )
- dupd editor-select-next mark>caret ;
-
-: editor-select ( from to editor -- )
- tuck editor-caret set-model editor-mark set-model ;
-
-: select-elt ( editor elt -- )
- over >r
- >r dup editor-caret* swap gadget-model r> prev/next-elt
- r> editor-select ;
-
-: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
-
-: end-of-document ( editor -- ) T{ doc-elt } editor-next ;
-
-: position-caret ( editor -- )
- mouse-elt dup T{ one-char-elt } =
- [ drop dup extend-selection dup editor-mark click-loc ]
- [ select-elt ] if ;
-
-: insert-newline ( editor -- ) "\n" swap user-input ;
-
-: delete-next-character ( editor -- )
- T{ char-elt } editor-delete ;
-
-: delete-previous-character ( editor -- )
- T{ char-elt } editor-backspace ;
-
-: delete-previous-word ( editor -- )
- T{ word-elt } editor-delete ;
-
-: delete-next-word ( editor -- )
- T{ word-elt } editor-backspace ;
-
-: delete-to-start-of-line ( editor -- )
- T{ one-line-elt } editor-delete ;
-
-: delete-to-end-of-line ( editor -- )
- T{ one-line-elt } editor-backspace ;
-
-editor "general" f {
- { T{ key-down f f "DELETE" } delete-next-character }
- { T{ key-down f { S+ } "DELETE" } delete-next-character }
- { T{ key-down f f "BACKSPACE" } delete-previous-character }
- { T{ key-down f { S+ } "BACKSPACE" } delete-previous-character }
- { T{ key-down f { C+ } "DELETE" } delete-previous-word }
- { T{ key-down f { C+ } "BACKSPACE" } delete-next-word }
- { T{ key-down f { A+ } "DELETE" } delete-to-start-of-line }
- { T{ key-down f { A+ } "BACKSPACE" } delete-to-end-of-line }
-} define-command-map
-
-: paste ( editor -- ) clipboard get paste-clipboard ;
-
-: paste-selection ( editor -- ) selection get paste-clipboard ;
-
-: cut ( editor -- ) clipboard get editor-cut ;
-
-editor "clipboard" f {
- { T{ paste-action } paste }
- { T{ button-up f f 2 } paste-selection }
- { T{ copy-action } com-copy }
- { T{ button-up } com-copy-selection }
- { T{ cut-action } cut }
-} define-command-map
-
-: previous-character ( editor -- )
- dup gadget-selection? [
- dup selection-start/end drop
- over set-caret mark>caret
- ] [
- T{ char-elt } editor-prev
- ] if ;
-
-: next-character ( editor -- )
- dup gadget-selection? [
- dup selection-start/end nip
- over set-caret mark>caret
- ] [
- T{ char-elt } editor-next
- ] if ;
-
-: previous-line ( editor -- ) T{ line-elt } editor-prev ;
-
-: next-line ( editor -- ) T{ line-elt } editor-next ;
-
-: previous-word ( editor -- ) T{ word-elt } editor-prev ;
-
-: next-word ( editor -- ) T{ word-elt } editor-next ;
-
-: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
-
-: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
-
-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 f "END" } end-of-line }
- { T{ key-down f { C+ } "HOME" } start-of-document }
- { T{ key-down f { C+ } "END" } end-of-document }
-} define-command-map
-
-: select-all ( editor -- ) T{ doc-elt } select-elt ;
-
-: select-line ( editor -- ) T{ one-line-elt } select-elt ;
-
-: select-word ( editor -- ) T{ one-word-elt } select-elt ;
-
-: selected-word ( editor -- string )
- dup gadget-selection?
- [ dup select-word ] unless
- gadget-selection ;
-
-: select-previous-character ( editor -- )
- T{ char-elt } editor-select-prev ;
-
-: select-next-character ( editor -- )
- T{ char-elt } editor-select-next ;
-
-: select-previous-line ( editor -- )
- T{ line-elt } editor-select-prev ;
-
-: select-next-line ( editor -- )
- T{ line-elt } editor-select-next ;
-
-: select-previous-word ( editor -- )
- T{ word-elt } editor-select-prev ;
-
-: select-next-word ( editor -- )
- T{ word-elt } editor-select-next ;
-
-: select-start-of-line ( editor -- )
- T{ one-line-elt } editor-select-prev ;
-
-: select-end-of-line ( editor -- )
- T{ one-line-elt } editor-select-next ;
-
-: select-start-of-document ( editor -- )
- T{ doc-elt } editor-select-prev ;
-
-: select-end-of-document ( editor -- )
- T{ doc-elt } editor-select-next ;
-
-editor "selection" f {
- { T{ button-down f { S+ } } extend-selection }
- { T{ drag } drag-selection }
- { T{ gain-focus } focus-editor }
- { T{ lose-focus } unfocus-editor }
- { T{ delete-action } remove-selection }
- { T{ select-all-action } select-all }
- { 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 }
- { T{ key-down f { S+ } "END" } select-end-of-line }
- { T{ key-down f { S+ C+ } "HOME" } select-start-of-document }
- { T{ key-down f { S+ C+ } "END" } select-end-of-document }
-} define-command-map
-
-! Multi-line editors
-TUPLE: multiline-editor < editor ;
-
-: <multiline-editor> ( -- editor )
- multiline-editor new-editor ;
-
-multiline-editor "general" f {
- { T{ key-down f f "RET" } insert-newline }
- { T{ key-down f { S+ } "RET" } insert-newline }
- { T{ key-down f f "ENTER" } insert-newline }
-} define-command-map
-
-TUPLE: source-editor < multiline-editor ;
-
-: <source-editor> ( -- editor )
- source-editor new-editor ;
-
-! Fields wrap an editor and edit an external model
-TUPLE: field < wrapper field-model editor ;
-
-: field-theme ( gadget -- gadget )
- gray <solid> >>boundary ; inline
-
-: <field-border> ( gadget -- border )
- 2 <border>
- { 1 0 } >>fill
- field-theme ;
-
-: <field> ( model -- gadget )
- <editor> dup <field-border> field new-wrapper
- swap >>editor
- swap >>field-model ;
-
-M: field graft*
- [ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ]
- [ dup editor>> model>> add-connection ]
- bi ;
-
-M: field ungraft*
- dup editor>> model>> remove-connection ;
-
-M: field model-changed
- nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
+++ /dev/null
-Editors edit a plain text document
+++ /dev/null
-
-USING: kernel alien.c-types combinators sequences splitting grouping
- opengl.gl ui.gadgets ui.render
- math math.vectors accessors math.geometry.rect ;
-
-IN: ui.gadgets.frame-buffer
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
- dup
- rect-dim product "uint[4]" <c-array>
- >>pixels ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: new-frame-buffer ( class -- gadget )
- new-gadget
- [ ] >>action
- { 100 100 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: draw-pixels ( fb -- fb )
- dup >r
- dup >r
- rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
- r> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: read-pixels ( fb -- fb )
- dup >r
- dup >r
- >r
- 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
- r> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer pref-dim* pdim>> ;
-M: frame-buffer graft* graft>> call ;
-M: frame-buffer ungraft* ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: copy-row ( old new -- )
- 2dup min-length swap >r head-slice 0 r> copy ;
-
-! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
-! [ group ] 2bi@
-! [ copy-row ] 2each ;
-
-! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
-! [ 16 * group ] 2bi@
-! [ copy-row ] 2each ;
-
-: copy-pixels ( old-pixels old-width new-pixels new-width -- )
- [ 16 * <sliced-groups> ] 2bi@
- [ copy-row ] 2each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer layout* ( fb -- )
- {
- {
- [ dup last-dim>> f = ]
- [
- init-frame-buffer-pixels
- dup
- rect-dim >>last-dim
- drop
- ]
- }
- {
- [ dup [ rect-dim ] [ last-dim>> ] bi = not ]
- [
- dup [ pixels>> ] [ last-dim>> first ] bi
-
- rot init-frame-buffer-pixels
- dup rect-dim >>last-dim
-
- [ pixels>> ] [ rect-dim first ] bi
-
- copy-pixels
- ]
- }
- { [ t ] [ drop ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: frame-buffer draw-gadget* ( fb -- )
-
- dup rect-dim { 0 1 } v* first2 glRasterPos2i
-
- draw-pixels
-
- dup action>> call
-
- glFlush
-
- read-pixels
-
- drop ;
-
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.syntax help.markup ui.gadgets kernel arrays
-quotations classes.tuple ui.gadgets.grids ;
-IN: ui.gadgets.frames
-
-ARTICLE: "ui-frame-layout" "Frame layouts"
-"Frames resemble " { $link "ui-grid-layout" } " except the size of grid is fixed at 3x3, and the center gadget fills up any available space. Because frames inherit from grids, grid layout words can be used to add and remove children."
-{ $subsection frame }
-"Creating empty frames:"
-{ $subsection <frame> }
-"A set of mnemonic words for the positions on a frame's 3x3 grid; these words push values which may be passed to " { $link grid-add } ":"
-{ $subsection @center }
-{ $subsection @left }
-{ $subsection @right }
-{ $subsection @top }
-{ $subsection @bottom }
-{ $subsection @top-left }
-{ $subsection @top-right }
-{ $subsection @bottom-left }
-{ $subsection @bottom-right } ;
-
-: $ui-frame-constant ( element -- )
- drop
- { $description "Symbolic constant for a common input to " { $link grid-add } "." } print-element ;
-
-HELP: @center $ui-frame-constant ;
-HELP: @left $ui-frame-constant ;
-HELP: @right $ui-frame-constant ;
-HELP: @top $ui-frame-constant ;
-HELP: @bottom $ui-frame-constant ;
-HELP: @top-left $ui-frame-constant ;
-HELP: @top-right $ui-frame-constant ;
-HELP: @bottom-left $ui-frame-constant ;
-HELP: @bottom-right $ui-frame-constant ;
-
-HELP: frame
-{ $class-description "A frame is a gadget which lays out its children in a 3x3 grid. If the frame is enlarged past its preferred size, the center gadget fills up available room."
-$nl
-"Frames are constructed by calling " { $link <frame> } " and since they inherit from " { $link grid } ", children can be managed with " { $link grid-add } " and " { $link grid-remove } "." } ;
-
-HELP: <frame>
-{ $values { "frame" frame } }
-{ $description "Creates a new " { $link frame } " for laying out gadgets in a 3x3 grid." } ;
-
-{ grid frame } related-words
-
-ABOUT: "ui-frame-layout"
+++ /dev/null
-IN: ui.gadgets.frames.tests
-USING: ui.gadgets.frames ui.gadgets tools.test ;
-
-[ ] [ <frame> layout ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic kernel math namespaces sequences words
-splitting grouping math.vectors ui.gadgets.grids ui.gadgets
-math.geometry.rect ;
-IN: ui.gadgets.frames
-
-! A frame arranges gadgets in a 3x3 grid, where the center
-! gadgets gets left-over space.
-TUPLE: frame < grid ;
-
-: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
-
-: @center 1 1 ;
-: @left 0 1 ;
-: @right 2 1 ;
-: @top 1 0 ;
-: @bottom 1 2 ;
-
-: @top-left 0 0 ;
-: @top-right 2 0 ;
-: @bottom-left 0 2 ;
-: @bottom-right 2 2 ;
-
-: new-frame ( class -- frame )
- <frame-grid> swap new-grid ; inline
-
-: <frame> ( -- frame )
- frame new-frame ;
-
-: (fill-center) ( vec n -- )
- over first pick third v+ [v-] 1 rot set-nth ;
-
-: fill-center ( horiz vert dim -- )
- tuck (fill-center) (fill-center) ;
-
-M: frame layout*
- dup compute-grid
- [ rot rect-dim fill-center ] 3keep
- grid-layout ;
+++ /dev/null
-Frames position children around a center child which fills up any remaining space
+++ /dev/null
-USING: help.markup help.syntax opengl kernel strings
- classes.tuple classes quotations models math.geometry.rect ;
-IN: ui.gadgets
-
-HELP: gadget-child
-{ $values { "gadget" gadget } { "child" gadget } }
-{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
-
-HELP: nth-gadget
-{ $values { "n" "a non-negative integer" } { "gadget" gadget } { "child" gadget } }
-{ $description "Outputs the " { $snippet "n" } "th child of the gadget." }
-{ $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ;
-
-HELP: <gadget>
-{ $values { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a new gadget." } ;
-
-HELP: relative-loc
-{ $values { "fromgadget" gadget } { "togadget" gadget } { "loc" "a pair of integers" } }
-{ $description
- "Outputs the location of the top-left corner of " { $snippet "togadget" } " relative to the co-ordinate system of " { $snippet "fromgadget" } "."
-}
-{ $errors
- "Throws an error if " { $snippet "togadget" } " is not contained in a child of " { $snippet "fromgadget" } "."
-} ;
-
-HELP: user-input*
-{ $values { "str" string } { "gadget" gadget } { "?" "a boolean" } }
-{ $contract "Handle free-form textual input while the gadget has keyboard focus." } ;
-
-HELP: children-on
-{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "gadget" gadget } { "seq" "a sequence of gadgets" } }
-{ $contract "Outputs a sequence of gadgets which potentially intersect a rectangle or contain a point in the co-ordinate system of the gadget." }
-{ $notes "This does not have to be an accurate intersection test, and simply returning " { $link gadget-children } " is a valid implementation. However, an accurate intersection test reduces the amount of work done when drawing this gadget if it is partially clipped and not all children are visible." } ;
-
-HELP: pick-up
-{ $values { "point" "a pair of integers" } { "gadget" gadget } { "child/f" "a " { $link gadget } " or " { $link f } } }
-{ $description "Outputs the child at a point in the gadget's co-ordinate system. This word recursively descends the gadget hierarchy, and so outputs the deepest child." } ;
-
-HELP: max-dim
-{ $values { "dims" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
-{ $description "Outputs the smallest dimensions of a rectangle which can fit all the dimensions in the sequence." } ;
-
-{ pref-dims max-dim dim-sum } related-words
-
-HELP: each-child
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( child -- )" } } }
-{ $description "Applies the quotation to each child of the gadget." } ;
-
-HELP: gadget-selection?
-{ $values { "gadget" gadget } { "?" "a boolean" } }
-{ $contract "Outputs if the gadget has an active text selection; if so, the selected text can be obtained with a call to " { $link gadget-selection } "." } ;
-
-HELP: gadget-selection
-{ $values { "gadget" gadget } { "string/f" "a " { $link string } " or " { $link f } } }
-{ $contract "Outputs the gadget's text selection, or " { $link f } " if nothing is selected." } ;
-
-HELP: relayout
-{ $values { "gadget" gadget } }
-{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout-1 } ", this relayouts all parents up to a gadget having " { $link gadget-root? } " set, so this word should be used when the gadget's dimensions have potentially changed." } ;
-
-HELP: relayout-1
-{ $values { "gadget" gadget } }
-{ $description "Relayout and redraw a gadget before the next iteration of the event loop. Unlike " { $link relayout } ", this does not propagate requests up to the parent, and so this word should only be used when the gadget's internal layout or appearance has changed, but the dimensions have not." } ;
-
-{ relayout relayout-1 } related-words
-
-HELP: pref-dim*
-{ $values { "gadget" gadget } { "dim" "a pair of integers" } }
-{ $contract "Outputs the preferred dimensions of the gadget, possibly computing them from the preferred dimensions of the gadget's children." }
-{ $notes "User code should not call this word directly, instead call " { $link pref-dim } "." } ;
-
-HELP: pref-dim
-{ $values { "gadget" gadget } { "dim" "a pair of integers" } }
-{ $description "Outputs the preferred dimensions of the gadget. The value is cached between calls, and invalidated when the gadget needs to be relayout." } ;
-
-HELP: pref-dims
-{ $values { "gadgets" "a sequence of gadgets" } { "seq" "a sequence of pairs of integers" } }
-{ $description "Collects the preferred dimensions of every gadget in the sequence into a new sequence." } ;
-
-HELP: layout*
-{ $values { "gadget" gadget } }
-{ $contract "Lays out the children of the gadget according to the gadget's policy. The dimensions of the gadget are already set by the parent by the time this word is called." }
-{ $notes "User code should not call this word directly, instead call " { $link relayout } " and " { $link relayout-1 } "." } ;
-
-HELP: prefer
-{ $values { "gadget" gadget } }
-{ $contract "Resizes the gadget to assume its preferred dimensions." } ;
-
-HELP: dim-sum
-{ $values { "seq" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
-{ $description "Sums a sequence of dimensions." } ;
-
-HELP: layout
-{ $values { "gadget" gadget } }
-{ $description "Lays out the children of the gadget if the gadget needs to be relayout, and otherwise does nothing." }
-{ $notes "User code should not call this word directly, instead call " { $link relayout } " and " { $link relayout-1 } "." } ;
-
-{ pref-dim pref-dim* layout layout* } related-words
-
-HELP: graft*
-{ $values { "gadget" gadget } }
-{ $contract "Called to notify the gadget it has become visible on the screen. This should set up timers and threads, and acquire any resources used by the gadget." } ;
-
-{ graft graft* ungraft ungraft* } related-words
-
-HELP: ungraft*
-{ $values { "gadget" gadget } }
-{ $contract "Called to notify the gadget it is no longer visible on the screen. This should stop timers and threads, and release any resources used by the gadget." } ;
-
-HELP: graft
-{ $values { "gadget" gadget } }
-{ $description "Calls " { $link graft* } " on the gadget and all children." }
-{ $notes "This word should never be called directly." } ;
-
-HELP: ungraft
-{ $values { "gadget" gadget } }
-{ $description "If the gadget is grafted, calls " { $link ungraft* } " on the gadget and all children." }
-{ $notes "This word should never be called directly." } ;
-
-HELP: unparent
-{ $values { "gadget" gadget } }
-{ $description "Removes the gadget from its parent. This will relayout the parent." }
-{ $notes "This may result in " { $link ungraft* } " being called on the gadget and its children, if the gadget's parent is visible on the screen." } ;
-
-HELP: clear-gadget
-{ $values { "gadget" gadget } }
-{ $description "Removes all children from the gadget. This will relayout the gadget." }
-{ $notes "This may result in " { $link ungraft* } " being called on the children, if the gadget is visible on the screen." }
-{ $side-effects "gadget" } ;
-
-HELP: add-gadget
-{ $values { "gadget" gadget } { "parent" gadget } }
-{ $description "Adds a child gadget to a parent. If the gadget is contained in another gadget, " { $link unparent } " is called on the gadget first. The parent will be relayout." }
-{ $notes "Adding a gadget to a parent may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
-{ $side-effects "parent" } ;
-
-HELP: add-gadgets
-{ $values { "seq" "a sequence of gadgets" } { "parent" gadget } }
-{ $description "Adds a sequence of gadgets to a parent. The parent will be relayout." }
-{ $notes "This may result in " { $link graft* } " being called on the children, if the parent is visible on the screen." }
-{ $side-effects "parent" } ;
-
-HELP: parents
-{ $values { "gadget" gadget } { "seq" "a sequence of gadgets" } }
-{ $description "Outputs a sequence of all parents of the gadget, with the first element being the gadget itself." } ;
-
-HELP: each-parent
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "?" "a boolean" } }
-{ $description "Applies the quotation to every parent of the gadget, starting from the gadget itself, stopping if the quotation yields " { $link f } ". Outputs " { $link t } " if the iteration completed, and outputs " { $link f } " if it was stopped prematurely." } ;
-
-HELP: find-parent
-{ $values { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( gadget -- ? )" } } { "parent" gadget } }
-{ $description "Outputs the first parent of the gadget, starting from the gadget itself, for which the quotation outputs a true value, or " { $link f } " if the quotation outputs " { $link f } " for every parent." } ;
-
-HELP: screen-loc
-{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
-{ $description "Outputs the location of the gadget relative to the top-left corner of the world containing the gadget. This word does not output a useful value if the gadget is not grafted." } ;
-
-HELP: child?
-{ $values { "parent" gadget } { "child" gadget } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "child" } " is contained inside " { $snippet "parent" } "." } ;
-
-HELP: focusable-child*
-{ $values { "gadget" gadget } { "child/t" "a " { $link gadget } " or " { $link t } } }
-{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus, or " { $link t } " if the gadget itself should receive focus." }
-{ $examples "For example, if your gadget consists of an editor together with an output area whose contents react to changes in editor contents, then the " { $link focusable-child* } " method for your gadget class should return the editor, so that when the gadget is displayed in a window or passed to " { $link request-focus } ", the editor receives keyboard focus automatically." } ;
-
-HELP: focusable-child
-{ $values { "gadget" gadget } { "child" gadget } }
-{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
-
-{ control-value set-control-value gadget-model } related-words
-
-HELP: control-value
-{ $values { "control" gadget } { "value" object } }
-{ $description "Outputs the value of the control's model." } ;
-
-HELP: set-control-value
-{ $values { "value" object } { "control" gadget } }
-{ $description "Sets the value of the control's model." } ;
-
-ARTICLE: "ui-control-impl" "Implementing controls"
-"A " { $emphasis "control" } " is a gadget which is linked to an underlying " { $link model } " by having its " { $link gadget-model } " slot set to a " { $link model } " instance."
-$nl
-"Some utility words useful in control implementations:"
-{ $subsection gadget-model }
-{ $subsection control-value }
-{ $subsection set-control-value }
-{ $see-also "models" } ;
+++ /dev/null
-IN: ui.gadgets.tests
-USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
-tools.test namespaces models kernel dlists dequeues math sets
-math.parser ui sequences hashtables assocs io arrays prettyprint
-io.streams.string math.geometry.rect ;
-
-[ { 300 300 } ]
-[
- ! c contains b contains a
- <gadget> "a" set
- <gadget> "b" set
- "a" get "b" get swap add-gadget drop
- <gadget> "c" set
- "b" get "c" get swap add-gadget drop
-
- ! position a and b
- { 100 200 } "a" get set-rect-loc
- { 200 100 } "b" get set-rect-loc
-
- ! give c a loc, it doesn't matter
- { -1000 23 } "c" get set-rect-loc
-
- ! what is the location of a inside c?
- "a" get "c" get relative-loc
-] unit-test
-
-<gadget> "g1" set
-{ 10 10 } "g1" get set-rect-loc
-{ 30 30 } "g1" get set-rect-dim
-<gadget> "g2" set
-{ 20 20 } "g2" get set-rect-loc
-{ 50 500 } "g2" get set-rect-dim
-<gadget> "g3" set
-{ 100 200 } "g3" get set-rect-dim
-
-"g1" get "g2" get swap add-gadget drop
-"g2" get "g3" get swap add-gadget drop
-
-[ { 30 30 } ] [ "g1" get screen-loc ] unit-test
-[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
-[ { 30 30 } ] [ "g1" get screen-rect rect-dim ] unit-test
-[ { 20 20 } ] [ "g2" get screen-loc ] unit-test
-[ { 20 20 } ] [ "g2" get screen-rect rect-loc ] unit-test
-[ { 50 180 } ] [ "g2" get screen-rect rect-dim ] unit-test
-[ { 0 0 } ] [ "g3" get screen-loc ] unit-test
-[ { 0 0 } ] [ "g3" get screen-rect rect-loc ] unit-test
-[ { 100 200 } ] [ "g3" get screen-rect rect-dim ] unit-test
-
-<gadget> "g1" set
-{ 300 300 } "g1" get set-rect-dim
-<gadget> "g2" set
-"g2" get "g1" get swap add-gadget drop
-{ 20 20 } "g2" get set-rect-loc
-{ 20 20 } "g2" get set-rect-dim
-<gadget> "g3" set
-"g3" get "g1" get swap add-gadget drop
-{ 100 100 } "g3" get set-rect-loc
-{ 20 20 } "g3" get set-rect-dim
-
-[ t ] [ { 30 30 } "g2" get inside? ] unit-test
-
-[ t ] [ { 30 30 } "g1" get (pick-up) "g2" get eq? ] unit-test
-
-[ t ] [ { 30 30 } "g1" get pick-up "g2" get eq? ] unit-test
-
-[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
-
-<gadget> "g4" set
-"g4" get "g2" get swap add-gadget drop
-{ 5 5 } "g4" get set-rect-loc
-{ 1 1 } "g4" get set-rect-dim
-
-[ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
-
-TUPLE: mock-gadget < gadget graft-called ungraft-called ;
-
-: <mock-gadget> ( -- gadget )
- mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ;
-
-M: mock-gadget graft*
- dup mock-gadget-graft-called 1+
- swap set-mock-gadget-graft-called ;
-
-M: mock-gadget ungraft*
- dup mock-gadget-ungraft-called 1+
- swap set-mock-gadget-ungraft-called ;
-
-! We can't print to output-stream here because that might be a pane
-! stream, and our graft-queue rebinding here would be captured
-! by code adding children to the pane...
-[
- <dlist> \ graft-queue [
- [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
- [ t ] [ graft-queue dequeue-empty? ] unit-test
- ] with-variable
-
- <dlist> \ graft-queue [
- [ t ] [ graft-queue dequeue-empty? ] unit-test
-
- <mock-gadget> "g" set
- [ ] [ "g" get queue-graft ] unit-test
- [ f ] [ graft-queue dequeue-empty? ] unit-test
- [ { f t } ] [ "g" get gadget-graft-state ] unit-test
- [ ] [ "g" get graft-later ] unit-test
- [ { f t } ] [ "g" get gadget-graft-state ] unit-test
- [ ] [ "g" get ungraft-later ] unit-test
- [ { f f } ] [ "g" get gadget-graft-state ] unit-test
- [ t ] [ graft-queue dequeue-empty? ] unit-test
- [ ] [ "g" get ungraft-later ] unit-test
- [ ] [ "g" get graft-later ] unit-test
- [ ] [ notify-queued ] unit-test
- [ { t t } ] [ "g" get gadget-graft-state ] unit-test
- [ t ] [ graft-queue dequeue-empty? ] unit-test
- [ ] [ "g" get graft-later ] unit-test
- [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
- [ ] [ "g" get ungraft-later ] unit-test
- [ { t f } ] [ "g" get gadget-graft-state ] unit-test
- [ ] [ notify-queued ] unit-test
- [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
- [ { f f } ] [ "g" get gadget-graft-state ] unit-test
- ] with-variable
-
- : add-some-children
- 3 [
- <mock-gadget> over <model> over set-gadget-model
- dup "g" get swap add-gadget drop
- swap 1+ number>string set
- ] each ;
-
- : status-flags
- { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
-
- : notify-combo ( ? ? -- )
- nl "===== Combo: " write 2dup 2array . nl
- <dlist> \ graft-queue [
- <mock-gadget> "g" set
- [ ] [ add-some-children ] unit-test
- [ V{ { f f } } ] [ status-flags ] unit-test
- [ ] [ "g" get graft ] unit-test
- [ V{ { f t } } ] [ status-flags ] unit-test
- dup [ [ ] [ notify-queued ] unit-test ] when
- [ ] [ "g" get clear-gadget ] unit-test
- [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
- [ [ ] [ notify-queued ] unit-test ] when
- [ ] [ add-some-children ] unit-test
- [ { f t } ] [ "1" get gadget-graft-state ] unit-test
- [ { f t } ] [ "2" get gadget-graft-state ] unit-test
- [ { f t } ] [ "3" get gadget-graft-state ] unit-test
- [ ] [ graft-queue [ "x" print notify ] slurp-dequeue ] unit-test
- [ ] [ notify-queued ] unit-test
- [ V{ { t t } } ] [ status-flags ] unit-test
- ] with-variable ;
-
- { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
-] with-string-writer print
-
-\ <gadget> must-infer
-\ unparent must-infer
-\ add-gadget must-infer
-\ add-gadgets must-infer
-\ clear-gadget must-infer
-
-\ relayout must-infer
-\ relayout-1 must-infer
-\ pref-dim must-infer
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables kernel models math namespaces
- sequences quotations math.vectors combinators sorting
- binary-search vectors dlists dequeues models threads
- concurrency.flags math.order math.geometry.rect ;
-
-IN: ui.gadgets
-
-SYMBOL: ui-notify-flag
-
-: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
-
-TUPLE: gadget < rect
- pref-dim parent children orientation focus
- visible? root? clipped? layout-state graft-state graft-node
- interior boundary
- model ;
-
-M: gadget equal? 2drop f ;
-
-M: gadget hashcode* drop gadget hashcode* ;
-
-M: gadget model-changed 2drop ;
-
-: gadget-child ( gadget -- child ) children>> first ;
-
-: nth-gadget ( n gadget -- child ) children>> nth ;
-
-: init-gadget ( gadget -- gadget )
- init-rect
- { 0 1 } >>orientation
- t >>visible?
- { f f } >>graft-state ; inline
-
-: new-gadget ( class -- gadget ) new init-gadget ; inline
-
-: <gadget> ( -- gadget )
- gadget new-gadget ;
-
-: activate-control ( gadget -- )
- dup model>> dup [
- 2dup add-connection
- swap model-changed
- ] [
- 2drop
- ] if ;
-
-: deactivate-control ( gadget -- )
- dup model>> dup [ 2dup remove-connection ] when 2drop ;
-
-: control-value ( control -- value )
- model>> model-value ;
-
-: set-control-value ( value control -- )
- model>> set-model ;
-
-: relative-loc ( fromgadget togadget -- loc )
- 2dup eq? [
- 2drop { 0 0 }
- ] [
- over rect-loc >r
- >r parent>> r> relative-loc
- r> v+
- ] if ;
-
-GENERIC: user-input* ( str gadget -- ? )
-
-M: gadget user-input* 2drop t ;
-
-GENERIC: children-on ( rect/point gadget -- seq )
-
-M: gadget children-on nip children>> ;
-
-: ((fast-children-on)) ( gadget dim axis -- <=> )
- [ swap loc>> v- ] dip v. 0 <=> ;
-
-: (fast-children-on) ( dim axis children -- i )
- -rot [ ((fast-children-on)) ] 2curry search drop ;
-
-: fast-children-on ( rect axis children -- from to )
- [ [ rect-loc ] 2dip (fast-children-on) 0 or ]
- [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
- 3bi ;
-
-: inside? ( bounds gadget -- ? )
- dup visible?>> [ intersects? ] [ 2drop f ] if ;
-
-: (pick-up) ( point gadget -- gadget )
- dupd children-on [ inside? ] with find-last nip ;
-
-: pick-up ( point gadget -- child/f )
- 2dup (pick-up) dup
- [ nip [ rect-loc v- ] keep pick-up ] [ rot 2drop ] if ;
-
-: max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
-
-: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
-
-: orient ( gadget seq1 seq2 -- seq )
- >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
-
-: each-child ( gadget quot -- )
- >r children>> r> each ; inline
-
-! Selection protocol
-GENERIC: gadget-selection? ( gadget -- ? )
-
-M: gadget gadget-selection? drop f ;
-
-GENERIC: gadget-selection ( gadget -- string/f )
-
-M: gadget gadget-selection drop f ;
-
-! Text protocol
-GENERIC: gadget-text* ( gadget -- )
-
-GENERIC: gadget-text-separator ( gadget -- str )
-
-M: gadget gadget-text-separator
- orientation>> { 0 1 } = "\n" "" ? ;
-
-: gadget-seq-text ( seq gadget -- )
- gadget-text-separator swap
- [ dup % ] [ gadget-text* ] interleave drop ;
-
-M: gadget gadget-text*
- dup children>> swap gadget-seq-text ;
-
-M: array gadget-text*
- [ gadget-text* ] each ;
-
-: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
-
-: invalidate ( gadget -- )
- \ invalidate swap (>>layout-state) ;
-
-: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
-
-: layout-queue ( -- queue ) \ layout-queue get ;
-
-: layout-later ( gadget -- )
- #! When unit testing gadgets without the UI running, the
- #! invalid queue is not initialized and we simply ignore
- #! invalidation requests.
- layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
-
-DEFER: relayout
-
-: invalidate* ( gadget -- )
- \ invalidate* over (>>layout-state)
- dup forget-pref-dim
- dup gadget-root?
- [ layout-later ] [ parent>> [ relayout ] when* ] if ;
-
-: relayout ( gadget -- )
- dup layout-state>> \ invalidate* eq?
- [ drop ] [ invalidate* ] if ;
-
-: relayout-1 ( gadget -- )
- dup layout-state>>
- [ drop ] [ dup invalidate layout-later ] if ;
-
-: show-gadget ( gadget -- ) t swap (>>visible?) ;
-
-: hide-gadget ( gadget -- ) f swap (>>visible?) ;
-
-DEFER: in-layout?
-
-: do-invalidate ( gadget -- gadget )
- in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
-
-M: gadget (>>dim) ( dim gadget -- )
- 2dup dim>> =
- [ 2drop ]
- [ tuck call-next-method do-invalidate drop ]
- if ;
-
-GENERIC: pref-dim* ( gadget -- dim )
-
-: ?set-gadget-pref-dim ( dim gadget -- )
- dup layout-state>>
- [ 2drop ] [ (>>pref-dim) ] if ;
-
-: pref-dim ( gadget -- dim )
- dup pref-dim>> [ ] [
- [ pref-dim* dup ] keep ?set-gadget-pref-dim
- ] ?if ;
-
-: pref-dims ( gadgets -- seq ) [ pref-dim ] map ;
-
-M: gadget pref-dim* rect-dim ;
-
-GENERIC: layout* ( gadget -- )
-
-M: gadget layout* drop ;
-
-: prefer ( gadget -- ) dup pref-dim swap (>>dim) ;
-
-: validate ( gadget -- ) f swap (>>layout-state) ;
-
-: layout ( gadget -- )
- dup layout-state>> [
- dup validate
- dup layout*
- dup [ layout ] each-child
- ] when drop ;
-
-: graft-queue ( -- dlist ) \ graft-queue get ;
-
-: unqueue-graft ( gadget -- )
- [ graft-node>> graft-queue delete-node ]
- [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
-
-: (queue-graft) ( gadget flags -- )
- >>graft-state
- dup graft-queue push-front* >>graft-node drop
- notify-ui-thread ;
-
-: queue-graft ( gadget -- )
- { f t } (queue-graft) ;
-
-: queue-ungraft ( gadget -- )
- { t f } (queue-graft) ;
-
-: graft-later ( gadget -- )
- dup graft-state>> {
- { { f t } [ drop ] }
- { { t t } [ drop ] }
- { { t f } [ unqueue-graft ] }
- { { f f } [ queue-graft ] }
- } case ;
-
-: ungraft-later ( gadget -- )
- dup graft-state>> {
- { { f f } [ drop ] }
- { { t f } [ drop ] }
- { { f t } [ unqueue-graft ] }
- { { t t } [ queue-ungraft ] }
- } case ;
-
-GENERIC: graft* ( gadget -- )
-
-M: gadget graft* drop ;
-
-: graft ( gadget -- )
- dup graft-later [ graft ] each-child ;
-
-GENERIC: ungraft* ( gadget -- )
-
-M: gadget ungraft* drop ;
-
-: ungraft ( gadget -- )
- dup [ ungraft ] each-child ungraft-later ;
-
-: (unparent) ( gadget -- )
- dup ungraft
- dup forget-pref-dim
- f swap (>>parent) ;
-
-: unfocus-gadget ( child gadget -- )
- tuck focus>> eq?
- [ f swap (>>focus) ] [ drop ] if ;
-
-SYMBOL: in-layout?
-
-: not-in-layout ( -- )
- in-layout? get
- [ "Cannot add/remove gadgets in layout*" throw ] when ;
-
-: unparent ( gadget -- )
- not-in-layout
- [
- dup parent>> dup [
- over (unparent)
- [ unfocus-gadget ] 2keep
- [ children>> delete ] keep
- relayout
- ] [
- 2drop
- ] if
- ] when* ;
-
-: (clear-gadget) ( gadget -- )
- dup [ (unparent) ] each-child
- f over (>>focus)
- f swap (>>children) ;
-
-: clear-gadget ( gadget -- )
- not-in-layout
- dup (clear-gadget) relayout ;
-
-: ((add-gadget)) ( parent child -- parent )
- over children>> ?push >>children ;
-
-: (add-gadget) ( parent child -- parent )
- dup unparent
- over >>parent
- tuck ((add-gadget))
- tuck graft-state>> second
- [ graft ]
- [ drop ]
- if ;
-
-: add-gadget ( parent child -- parent )
- not-in-layout
- (add-gadget)
- dup relayout ;
-
-: add-gadgets ( parent children -- parent )
- not-in-layout
- [ (add-gadget) ] each
- dup relayout ;
-
-: parents ( gadget -- seq )
- [ parent>> ] follow ;
-
-: each-parent ( gadget quot -- ? )
- >r parents r> all? ; inline
-
-: find-parent ( gadget quot -- parent )
- >r parents r> find nip ; inline
-
-: screen-loc ( gadget -- loc )
- parents { 0 0 } [ rect-loc v+ ] reduce ;
-
-: (screen-rect) ( gadget -- loc ext )
- dup parent>> [
- >r rect-extent r> (screen-rect)
- >r tuck v+ r> vmin >r v+ r>
- ] [
- rect-extent
- ] if* ;
-
-: screen-rect ( gadget -- rect )
- (screen-rect) <extent-rect> ;
-
-: child? ( parent child -- ? )
- {
- { [ 2dup eq? ] [ 2drop t ] }
- { [ dup not ] [ 2drop f ] }
- [ parent>> child? ]
- } cond ;
-
-GENERIC: focusable-child* ( gadget -- child/t )
-
-M: gadget focusable-child* drop t ;
-
-: focusable-child ( gadget -- child )
- dup focusable-child*
- dup t eq? [ drop ] [ nip focusable-child ] if ;
-
-GENERIC: request-focus-on ( child gadget -- )
-
-M: gadget request-focus-on parent>> request-focus-on ;
-
-M: f request-focus-on 2drop ;
-
-: request-focus ( gadget -- )
- [ focusable-child ] keep request-focus-on ;
-
-: focus-path ( world -- seq )
- [ focus>> ] follow ;
-
-! Deprecated
-
-: construct-gadget ( class -- tuple )
- >r <gadget> { set-delegate } r> construct ; inline
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax ui.gadgets.grids
-ui.render ;
-IN: ui.gadgets.grid-lines
-
-HELP: grid-lines
-{ $class-description "A class implementing the " { $link draw-boundary } " generic word to draw lines between the cells of a " { $link grid } ". The color of the lines is a color specifier stored in the " { $link grid-lines-color } " slot." } ;
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces opengl opengl.gl sequences
-math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
-IN: ui.gadgets.grid-lines
-
-TUPLE: grid-lines color ;
-
-C: <grid-lines> grid-lines
-
-SYMBOL: grid-dim
-
-: half-gap grid get grid-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 ;
-
-: draw-grid-lines ( gaps orientation -- )
- grid get rot grid-positions grid get rect-dim suffix [
- grid-line-from/to gl-line
- ] with each ;
-
-M: grid-lines draw-boundary
- origin get [
- -0.5 -0.5 0.0 glTranslated
- grid-lines-color set-color [
- dup grid set
- dup rect-dim half-gap v- grid-dim set
- compute-grid
- { 0 1 } draw-grid-lines
- { 1 0 } draw-grid-lines
- ] with-scope
- ] with-translation ;
+++ /dev/null
-Grid lines visibly separate children of grids and frames
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax arrays ;
-IN: ui.gadgets.grids
-
-ARTICLE: "ui-grid-layout" "Grid layouts"
-"Grid gadgets layout their children in a rectangular grid."
-{ $subsection grid }
-"Creating grids from a fixed set of gadgets:"
-{ $subsection <grid> }
-"Managing chidren:"
-{ $subsection grid-add }
-{ $subsection grid-remove }
-{ $subsection grid-child } ;
-
-HELP: grid
-{ $class-description "A grid gadget lays out its children so that all gadgets in a column have equal width and all gadgets in a row have equal height."
-$nl
-"The " { $link grid-gap } " slot stores a pair of integers, the horizontal and vertical gap between children, respectively."
-$nl
-"The " { $link grid-fill? } " slot stores a boolean, indicating if grid cells should assume their preferred size, or if they should fill the dimensions of the cell. The default is " { $link t } "."
-$nl
-"Grids are created by calling " { $link <grid> } " and children are managed with " { $link grid-add } " and " { $link grid-remove } "."
-$nl
-"The " { $link add-gadget } ", " { $link unparent } " and " { $link clear-gadget } " words should not be used to manage child gadgets of grids." } ;
-
-HELP: <grid>
-{ $values { "children" "a sequence of sequences of gadgets" } { "grid" "a new " { $link grid } } }
-{ $description "Creates a new " { $link grid } " gadget with the given children." } ;
-
-HELP: grid-child
-{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } { "gadget" gadget } }
-{ $description "Outputs the child gadget at the " { $snippet "i" } "," { $snippet "j" } "th position of the grid." }
-{ $errors "Throws an error if the indices are out of bounds." } ;
-
-HELP: grid-add
-{ $values { "gadget" gadget } { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
-{ $description "Adds a child gadget at the specified location." }
-{ $side-effects "grid" } ;
-
-HELP: grid-remove
-{ $values { "grid" grid } { "i" "non-negative integer" } { "j" "non-negative integer" } }
-{ $description "Removes a child gadget from the specified location." }
-{ $side-effects "grid" } ;
-
-ABOUT: "ui-grid-layout"
+++ /dev/null
-USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
-namespaces math.geometry.rect ;
-IN: ui.gadgets.grids.tests
-
-[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
-
-: 100x100 <gadget> { 100 100 } over set-rect-dim ;
-
-[ { 100 100 } ] [
- 100x100
- 1array 1array <grid> pref-dim
-] unit-test
-
-[ { 100 100 } ] [
- 100x100
- 1array 1array <grid> pref-dim
-] unit-test
-
-[ { 200 100 } ] [
- 100x100
- 100x100
- 2array 1array <grid> pref-dim
-] unit-test
-
-[ { 100 200 } ] [
- 100x100
- 100x100
- [ 1array ] bi@ 2array <grid> pref-dim
-] unit-test
-
-[ ] [
- 100x100
- 100x100
- [ 1array ] bi@ 2array <grid> layout
-] unit-test
-
-[ { 230 120 } { 100 100 } { 100 100 } ] [
- 100x100 dup "a" set
- 100x100 dup "b" set
- 2array 1array <grid>
- { 10 10 } over set-grid-gap
- dup prefer
- dup layout
- rect-dim
- "a" get rect-dim
- "b" get rect-dim
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math namespaces sequences words io
-io.streams.string math.vectors ui.gadgets columns accessors
-math.geometry.rect ;
-IN: ui.gadgets.grids
-
-TUPLE: grid < gadget
-grid
-{ gap initial: { 0 0 } }
-{ fill? initial: t } ;
-
-: new-grid ( children class -- grid )
- new-gadget
- [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
- inline
-
-: <grid> ( children -- grid )
- grid new-grid ;
-
-: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
-
-: grid-add ( grid child i j -- grid )
- >r >r dupd swap r> r>
- >r >r 2dup swap add-gadget drop r> r>
- 3dup grid-child unparent rot grid>> nth set-nth ;
-
-: grid-remove ( grid i j -- grid ) <gadget> -rot grid-add ;
-
-: pref-dim-grid ( grid -- dims )
- grid>> [ [ pref-dim ] map ] map ;
-
-: (compute-grid) ( grid -- seq ) [ max-dim ] map ;
-
-: compute-grid ( grid -- horiz vert )
- pref-dim-grid dup flip (compute-grid) swap (compute-grid) ;
-
-: (pair-up) ( horiz vert -- dim )
- >r first r> second 2array ;
-
-: pair-up ( horiz vert -- dims )
- [ [ (pair-up) ] curry map ] with map ;
-
-: add-gaps ( gap seq -- newseq )
- [ v+ ] with map ;
-
-: gap-sum ( gap seq -- newseq )
- dupd add-gaps dim-sum v+ ;
-
-M: grid pref-dim*
- dup grid-gap swap compute-grid >r over r>
- gap-sum >r gap-sum r> (pair-up) ;
-
-: do-grid ( dims grid quot -- )
- -rot grid>>
- [ [ pick call ] 2each ] 2each
- drop ; inline
-
-: grid-positions ( grid dims -- locs )
- >r grid-gap dup r> add-gaps swap [ v+ ] accumulate nip ;
-
-: position-grid ( grid horiz vert -- )
- pick >r
- >r over r> grid-positions >r grid-positions r>
- pair-up r> [ set-rect-loc ] do-grid ;
-
-: resize-grid ( grid horiz vert -- )
- pick grid-fill? [
- pair-up swap [ (>>dim) ] do-grid
- ] [
- 2drop grid>> [ [ prefer ] each ] each
- ] if ;
-
-: grid-layout ( grid horiz vert -- )
- [ position-grid ] 3keep resize-grid ;
-
-M: grid layout* dup compute-grid grid-layout ;
-
-M: grid children-on ( rect gadget -- seq )
- dup gadget-children empty? [
- 2drop f
- ] [
- { 0 1 } swap grid>>
- [ 0 <column> fast-children-on ] keep
- <slice> concat
- ] if ;
-
-M: grid gadget-text*
- grid>>
- [ [ gadget-text ] map ] map format-table
- [ CHAR: \n , ] [ % ] interleave ;
+++ /dev/null
-Grids arrange children in a variable-size grid
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel assocs ui.gestures ui.gadgets.wrappers accessors ;
-
-IN: ui.gadgets.handler
-
-TUPLE: handler < wrapper table ;
-
-: <handler> ( child -- handler ) handler new-wrapper ;
-
-M: handler handle-gesture* ( gadget gesture delegate -- ? )
- table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax ui.gadgets.packs ;
-IN: ui.gadgets.incremental
-
-HELP: incremental
-{ $class-description "Incremental layout gadgets inherit from " { $link pack } " and implement an optimization where the relayout operation after adding a child to be done in constant time."
-$nl
-"Incremental layout gadgets are created by calling " { $link <incremental> } "."
-$nl
-"Children are managed with the " { $link add-incremental } " and " { $link clear-incremental } " words."
-$nl
-"Not every " { $link pack } " can use incremental layout, since incremental layout does not support non-default values for " { $link pack-align } ", " { $link pack-fill } ", and " { $link pack-gap } "." } ;
-
-HELP: <incremental>
-{ $values { "pack" pack } { "incremental" "a new instance of " { $link incremental } } }
-{ $description "Creates a new incremental layout gadget delegating to " { $snippet "pack" } "." } ;
-
-{ <incremental> add-incremental clear-incremental } related-words
-
-HELP: add-incremental
-{ $values { "gadget" gadget } { "incremental" incremental } }
-{ $description "Adds the gadget to the incremental layout and performs relayout immediately in constant time." }
-{ $side-effects "incremental" } ;
-
-HELP: clear-incremental
-{ $values { "incremental" incremental } }
-{ $description "Removes all gadgets from the incremental layout and performs relayout immediately in constant time." }
-{ $side-effects "incremental" } ;
-
-ARTICLE: "ui-incremental-layout" "Incremental layouts"
-"Incremental layout gadgets are like " { $link "ui-pack-layout" } " except the relayout operation after adding a new child can be done in constant time."
-$nl
-"With all layouts, relayout requests from consecutive additions and removals are of children are coalesced and result in only one relayout operation being performed, however the run time of the relayout operation itself depends on the number of children."
-$nl
-"Incremental layout is used by " { $link "ui.gadgets.panes" } " to ensure that new lines of output does not take longer to display when the pane already has previous output."
-$nl
-"Incremental layouts are not a general replacement for " { $link "ui-pack-layout" } " and there are some limitations to be aware of."
-{ $subsection incremental }
-{ $subsection <incremental> }
-"Children are added and removed with a special set of words which perform necessary relayout immediately:"
-{ $subsection add-incremental }
-{ $subsection clear-incremental }
-"Calling " { $link unparent } " to remove a child of an incremental layout is permitted, however the relayout following the removal will not be performed in constant time, because all gadgets following the removed gadget need to be moved." ;
-
-ABOUT: "ui-incremental-layout"
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel math namespaces math.vectors ui.gadgets
-ui.gadgets.packs accessors math.geometry.rect ;
-IN: ui.gadgets.incremental
-
-! Incremental layout allows adding lines to panes to be O(1).
-! Note that incremental packs are distinct from ordinary packs
-! defined in layouts.factor, since you don't want all packs to
-! be incremental. In particular, incremental packs do not
-! support non-default values for pack-align, pack-fill and
-! pack-gap.
-
-! The cursor is the current size of the incremental pack.
-! New gadgets are added at
-! incremental-cursor gadget-orientation v*
-
-TUPLE: incremental < pack cursor ;
-
-: <incremental> ( -- incremental )
- incremental new-gadget
- { 0 1 } >>orientation
- { 0 0 } >>cursor ;
-
-M: incremental pref-dim*
- dup gadget-layout-state [
- dup call-next-method over set-incremental-cursor
- ] when incremental-cursor ;
-
-: next-cursor ( gadget incremental -- cursor )
- [
- swap rect-dim swap incremental-cursor
- 2dup v+ >r vmax r>
- ] keep gadget-orientation set-axis ;
-
-: update-cursor ( gadget incremental -- )
- [ next-cursor ] keep set-incremental-cursor ;
-
-: incremental-loc ( gadget incremental -- )
- dup incremental-cursor swap gadget-orientation v*
- swap set-rect-loc ;
-
-: prefer-incremental ( gadget -- )
- dup forget-pref-dim dup pref-dim swap set-rect-dim ;
-
-: add-incremental ( gadget incremental -- )
- not-in-layout
- 2dup swap (add-gadget) drop
- over prefer-incremental
- over layout-later
- 2dup incremental-loc
- tuck update-cursor
- dup prefer-incremental
- gadget-parent [ invalidate* ] when* ;
-
-: clear-incremental ( incremental -- )
- not-in-layout
- dup (clear-gadget)
- dup forget-pref-dim
- { 0 0 } over set-incremental-cursor
- gadget-parent [ relayout ] when* ;
+++ /dev/null
-Children can be added to incremental layouts in constant time
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax strings models
-ui.gadgets.panes ;
-IN: ui.gadgets.labelled
-
-HELP: labelled-gadget
-{ $class-description "A labelled gadget can be created by calling " { $link <labelled-gadget> } "." } ;
-
-HELP: <labelled-gadget>
-{ $values { "gadget" gadget } { "title" string } { "newgadget" "a new " { $link <labelled-gadget> } } }
-{ $description "Creates a new " { $link labelled-gadget } " display " { $snippet "gadget" } " with " { $snippet "title" } " on top." } ;
-
-HELP: closable-gadget
-{ $class-description "A closable gadget displays a title bar with a close box on top of another gadget. Clicking the close box invokes a quotation. Closable gadgets are created by calling " { $link <closable-gadget> } "." } ;
-
-HELP: <closable-gadget>
-{ $values { "gadget" gadget } { "title" string } { "quot" "a quotation with stack effect " { $snippet "( button -- )" } } }
-{ $description "Creates a new " { $link closable-gadget } ". Clicking the close box calls " { $snippet "quot" } "." }
-{ $notes "The quotation can find the " { $link closable-gadget } " instance, or any other parent gadget by calling " { $link find-parent } " with the gadget it receives on the stack." } ;
-
-HELP: <labelled-pane>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "scrolls?" "a boolean" } { "title" string } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a new control delegating to a " { $link pane } ", and wraps it in a " { $link labelled-gadget } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
-
-{ <labelled-pane> <pane-control> } related-words
-
-ARTICLE: "ui.gadgets.labelled" "Labelled gadgets"
-"It is possible to create a labelled border around a child gadget:"
-{ $subsection labelled-gadget }
-{ $subsection <labelled-gadget> }
-"Or a labelled border with a close box:"
-{ $subsection closable-gadget }
-{ $subsection <closable-gadget> } ;
-
-ABOUT: "ui.gadgets.labelled"
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets.buttons ui.gadgets.borders
-ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
-ui.gadgets.grids io kernel math models namespaces prettyprint
-sequences sequences words classes.tuple ui.gadgets ui.render
-colors accessors ;
-IN: ui.gadgets.labelled
-
-TUPLE: labelled-gadget < track content ;
-
-: <labelled-gadget> ( gadget title -- newgadget )
- { 0 1 } labelled-gadget new-track
- swap <label> reverse-video-theme f track-add
- swap >>content
- dup content>> 1 track-add ;
-
-M: labelled-gadget focusable-child* labelled-gadget-content ;
-
-: <labelled-scroller> ( gadget title -- gadget )
- >r <scroller> r> <labelled-gadget> ;
-
-: <labelled-pane> ( model quot scrolls? title -- gadget )
- >r >r <pane-control> r> over set-pane-scrolls? r>
- <labelled-scroller> ;
-
-: <close-box> ( quot -- button/f )
- gray close-box <polygon-gadget> swap <bevel-button> ;
-
-: title-theme ( gadget -- )
- { 1 0 } over set-gadget-orientation
- T{ gradient f {
- T{ rgba f 0.65 0.65 1.0 1.0 }
- T{ rgba f 0.65 0.45 1.0 1.0 }
- } } swap set-gadget-interior ;
-
-: <title-label> ( text -- label ) <label> dup title-theme ;
-
-: <title-bar> ( title quot -- gadget )
- <frame>
- swap dup [ <close-box> @left grid-add ] [ drop ] if
- swap <title-label> @center grid-add ;
-
-TUPLE: closable-gadget < frame content ;
-
-: find-closable-gadget ( parent -- child )
- [ [ closable-gadget? ] is? ] find-parent ;
-
-: <closable-gadget> ( gadget title quot -- gadget )
- closable-gadget new-frame
- -rot <title-bar> @top grid-add
- swap >>content
- dup content>> @center grid-add ;
-
-M: closable-gadget focusable-child* closable-gadget-content ;
+++ /dev/null
-Labelled gadgets display a border with a text label surrounding a child
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax strings ui.gadgets models ;
-IN: ui.gadgets.labels
-
-HELP: label
-{ $class-description "A label displays a piece of text, either a single line string or an array of line strings. Labels are created by calling " { $link <label> } "." } ;
-
-HELP: <label>
-{ $values { "string" string } { "label" "a new " { $link label } } }
-{ $description "Creates a new " { $link label } " gadget. The string is permitted to contain line breaks." } ;
-
-HELP: label-string
-{ $values { "label" label } { "string" string } }
-{ $description "Outputs the string currently displayed by the label." } ;
-
-HELP: set-label-string
-{ $values { "label" label } { "string" string } }
-{ $description "Sets the string currently displayed by the label. The string is permitted to contain line breaks. After calling this word, you must also call " { $link relayout } " on the label." } ;
-
-HELP: <label-control>
-{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a control which displays the value of " { $snippet "model" } ", which is required to be a string. The label control is automatically updated when the model value changes." } ;
-
-{ label-string set-label-string } related-words
-{ <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."
-{ $subsection label }
-{ $subsection <label> }
-{ $subsection <label-control> }
-{ $subsection label-string }
-{ $subsection set-label-string }
-"Label specifiers are used by buttons, checkboxes and radio buttons:"
-{ $subsection >label } ;
-
-ABOUT: "ui.gadgets.labels"
-
-HELP: >label
-{ $values { "obj" "a label specifier" } { "gadget" "a new " { $link gadget } } }
-{ $description "Convert the object into a gadget suitable for use as the label of a button. If " { $snippet "obj" } " is already a gadget, does nothing. Otherwise creates a " { $link label } " gadget if it is a string and an empty gadget if " { $snippet "obj" } " is " { $link f } "." } ;
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables io kernel math namespaces
-opengl sequences strings splitting
-ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
-models ;
-IN: ui.gadgets.labels
-
-! A label gadget draws a string.
-TUPLE: label < gadget text font color ;
-
-: label-string ( label -- string )
- text>> dup string? [ "\n" join ] unless ; inline
-
-: set-label-string ( string label -- )
- CHAR: \n pick memq? [
- >r string-lines r> set-label-text
- ] [
- set-label-text
- ] if ; inline
-
-: label-theme ( gadget -- gadget )
- sans-serif-font >>font
- black >>color ; inline
-
-: new-label ( string class -- label )
- new-gadget
- [ set-label-string ] keep
- label-theme ; inline
-
-: <label> ( string -- label )
- label new-label ;
-
-M: label pref-dim*
- [ font>> open-font ] [ text>> ] bi text-dim ;
-
-M: label draw-gadget*
- [ color>> set-color ]
- [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
-
-M: label gadget-text* label-string % ;
-
-TUPLE: label-control < label ;
-
-M: label-control model-changed
- swap model-value over set-label-string relayout ;
-
-: <label-control> ( model -- gadget )
- "" label-control new-label
- swap >>model ;
-
-: text-theme ( gadget -- gadget )
- black >>color
- monospace-font >>font ;
-
-: reverse-video-theme ( label -- label )
- white >>color
- black solid-interior ;
-
-GENERIC: >label ( obj -- gadget )
-M: string >label <label> ;
-M: array >label <label> ;
-M: object >label ;
-M: f >label drop <gadget> ;
-
-: label-on-left ( gadget label -- button )
- { 1 0 } <track>
- swap >label f track-add
- swap 1 track-add ;
-
-: label-on-right ( label gadget -- button )
- { 1 0 } <track>
- swap f track-add
- swap >label 1 track-add ;
+++ /dev/null
-Label gadgets display one or more lines of text with a single font and color
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: ui.backend ui.gadgets.worlds ;
-
-IN: ui.gadgets.lib
-
-: find-gl-context ( gadget -- ) find-world world-handle select-gl-context ;
+++ /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" "a quotation with stack effect " { $snippet "( list -- )" } } { "presenter" "a quotation with stack effect " { $snippet "( 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 list-index over calc-bounded-index
- swap set-list-index ;
-
-: list-presentation-hook ( list -- quot )
- hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
-
-: <list-presentation> ( hook elt presenter -- gadget )
- keep >r >label text-theme r>
- <presentation>
- swap >>hook ; inline
-
-: <list-items> ( list -- seq )
- [ list-presentation-hook ]
- [ presenter>> ]
- [ control-value ]
- tri [
- >r 2dup r> swap <list-presentation>
- ] map 2nip ;
-
-M: list model-changed
- nip
- dup clear-gadget
- dup <list-items> over swap add-gadgets drop
- bound-index ;
-
-: selected-rect ( list -- rect )
- dup list-index swap gadget-children ?nth ;
-
-M: list draw-gadget*
- origin get [
- dup list-color set-color
- selected-rect [ rect-extent gl-fill-rect ] when*
- ] with-translation ;
-
-M: list focusable-child* drop t ;
-
-: list-value ( list -- object )
- dup list-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
- [ set-list-index ] keep
- [ relayout-1 ] keep
- scroll>selected
- ] if ;
-
-: select-previous ( list -- )
- dup list-index 1- swap select-index ;
-
-: select-next ( list -- )
- dup list-index 1+ swap select-index ;
-
-: invoke-value-action ( list -- )
- dup list-empty? [
- dup list-hook call
- ] [
- dup list-index swap nth-gadget invoke-secondary
- ] if ;
-
-: select-gadget ( gadget list -- )
- swap over gadget-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 -- )
- >r dup selected-rect rect-bounds 2 v/n v+
- over visible-dim r> 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax ui.gadgets.worlds
-kernel ;
-IN: ui.gadgets.menus
-
-HELP: <commands-menu>
-{ $values { "hook" "a quotation with stack effect " { $snippet "( button -- )" } } { "target" object } { "commands" "a sequence of commands" } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
-
-HELP: show-menu
-{ $values { "gadget" gadget } { "owner" gadget } }
-{ $description "Displays a popup menu in the " { $link world } " containing " { $snippet "owner" } " at the current mouse location." } ;
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.commands 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 ;
-IN: ui.gadgets.menus
-
-: menu-loc ( world menu -- loc )
- >r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
-
-TUPLE: menu-glass < gadget ;
-
-: <menu-glass> ( menu world -- glass )
- menu-glass new-gadget
- >r over menu-loc over set-rect-loc r>
- [ swap add-gadget drop ] keep ;
-
-M: menu-glass layout* gadget-child prefer ;
-
-: hide-glass ( world -- )
- dup world-glass [ unparent ] when*
- f swap set-world-glass ;
-
-: show-glass ( gadget world -- )
- over hand-clicked set-global
- [ hide-glass ] keep
- [ swap add-gadget drop ] 2keep
- set-world-glass ;
-
-: show-menu ( gadget owner -- )
- find-world [ <menu-glass> ] keep show-glass ;
-
-\ menu-glass H{
- { T{ button-down } [ find-world [ hide-glass ] when* ] }
- { T{ drag } [ update-clicked drop ] }
-} set-gestures
-
-: <menu-item> ( hook target command -- button )
- dup command-name -rot command-button-quot
- swapd
- [ hand-clicked get find-world hide-glass ]
- 3append <roll-button> ;
-
-: menu-theme ( gadget -- gadget )
- light-gray solid-interior
- faint-boundary ;
-
-: <commands-menu> ( hook target commands -- gadget )
- <filled-pile>
- -roll
- [ <menu-item> add-gadget ] with with each
- 5 <border> menu-theme ;
+++ /dev/null
-Menu gadgets pop up as a list of commands at the mouse location
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax generic kernel
-classes.tuple quotations ;
-IN: ui.gadgets.packs
-
-ARTICLE: "ui-pack-layout" "Pack layouts"
-"Pack gadgets layout their children along a single axis."
-{ $subsection pack }
-"Creating empty packs:"
-{ $subsection <pack> }
-{ $subsection <pile> }
-{ $subsection <shelf> }
-
-"For more control, custom layouts can reuse portions of pack layout logic:"
-{ $subsection pack-pref-dim }
-{ $subsection pack-layout } ;
-
-HELP: pack
-{ $class-description "A gadget which lays out its children along a single axis stored in the " { $link gadget-orientation } " slot. Can be constructed with one of the following words:"
-{ $list
- { $link <pack> }
- { $link <pile> }
- { $link <shelf> }
-}
-"Packs have the following slots:"
-{ $list
- { { $link pack-align } " a rational number between 0 and 1, the alignment of gadgets along the axis perpendicular to the pack's orientation" }
- { { $link pack-fill } " a rational number between 0 and 1, where 0 gives each gadget its preferred size and 1 fills the dimension perpendicular to the pack's orientation" }
- { { $link pack-gap } " a pair of integers, the horizontal and vertical gap between children" }
-}
-"Custom gadgets can inherit from the " { $link pack } " class and implement their own " { $link pref-dim* } " and " { $link layout* } " methods, reusing pack layout logic by calling " { $link pack-pref-dim } " and " { $link pack-layout } "." } ;
-
-HELP: pack-layout
-{ $values { "pack" "a new " { $link pack } } { "sizes" "a sequence of pairs of integers" } }
-{ $description "Lays out the pack's children along the " { $link gadget-orientation } " of the pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
-{ $notes
- "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
-} ;
-
-HELP: <pack>
-{ $values { "orientation" "an orientation specifier" } { "pack" "a new " { $link pack } } }
-{ $description "Creates a new pack which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
-
-{ <pack> <pile> <shelf> } related-words
-
-HELP: <pile>
-{ $values { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out its children vertically." } ;
-
-HELP: <shelf>
-{ $values { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out its children horizontally." } ;
-
-HELP: pack-pref-dim
-{ $values { "gadget" gadget } { "sizes" "a sequence of pairs of integers" } { "dim" "a pair of integers" } }
-{ $description "Computes the preferred size of a pack, with each gadget receiving its size from the corresponding index of the " { $snippet "sizes" } " sequence." }
-{ $notes
- "This word is useful if you are writing your own layout gadget which inherits from " { $link pack } ". This allows you to reuse layout logic while computing gadget sizes using a custom procedure."
-} ;
-
-ABOUT: "ui-pack-layout"
+++ /dev/null
-IN: ui.gadgets.packs.tests
-USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render
-kernel namespaces tools.test math.parser sequences math.geometry.rect ;
-
-[ t ] [
- { 0 0 } { 100 100 } <rect> clip set
-
- <pile>
- 100 [ number>string <label> add-gadget ] each
- dup layout
-
- visible-children [ label? ] all?
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences ui.gadgets kernel math math.functions
-math.vectors namespaces math.order accessors math.geometry.rect ;
-IN: ui.gadgets.packs
-
-TUPLE: pack < gadget
-{ align initial: 0 }
-{ fill initial: 0 }
-{ gap initial: { 0 0 } } ;
-
-: packed-dim-2 ( gadget sizes -- list )
- [ over rect-dim over v- rot pack-fill v*n v+ ] with map ;
-
-: packed-dims ( gadget sizes -- seq )
- 2dup packed-dim-2 swap orient ;
-
-: gap-locs ( gap sizes -- seq )
- { 0 0 } [ v+ over v+ ] accumulate 2nip ;
-
-: aligned-locs ( gadget sizes -- seq )
- [ >r dup pack-align swap rect-dim r> v- n*v ] with map ;
-
-: packed-locs ( gadget sizes -- seq )
- over pack-gap over gap-locs >r dupd aligned-locs r> orient ;
-
-: round-dims ( seq -- newseq )
- { 0 0 } swap
- [ swap v- dup [ ceiling >fixnum ] map [ swap v- ] keep ] map
- nip ;
-
-: pack-layout ( pack sizes -- )
- round-dims over gadget-children
- >r dupd packed-dims r> 2dup [ (>>dim) ] 2each
- >r packed-locs r> [ set-rect-loc ] 2each ;
-
-: <pack> ( orientation -- pack )
- pack new-gadget
- swap >>orientation ;
-
-: <pile> ( -- pack ) { 0 1 } <pack> ;
-
-: <filled-pile> ( -- pack ) <pile> 1 over set-pack-fill ;
-
-: <shelf> ( -- pack ) { 1 0 } <pack> ;
-
-: gap-dims ( gap sizes -- seeq )
- [ dim-sum ] keep length 1 [-] rot n*v v+ ;
-
-: pack-pref-dim ( gadget sizes -- dim )
- over pack-gap over gap-dims >r max-dim r>
- rot gadget-orientation set-axis ;
-
-M: pack pref-dim*
- dup gadget-children pref-dims pack-pref-dim ;
-
-M: pack layout*
- dup gadget-children pref-dims pack-layout ;
-
-M: pack children-on ( rect gadget -- seq )
- dup gadget-orientation swap gadget-children
- [ fast-children-on ] keep <slice> ;
+++ /dev/null
-Pack gadgets arrange children horizontally or vertically
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets models help.markup help.syntax io kernel
-quotations ;
-IN: ui.gadgets.panes
-
-HELP: pane
-{ $class-description "A pane " { $link gadget } " displays formatted text which is written to a " { $link pane-stream } " targetting the pane. Panes are created by calling " { $link <pane> } ", " { $link <scrolling-pane> } " or " { $link <pane-control> } "." } ;
-
-HELP: <pane>
-{ $values { "pane" "a new " { $link pane } } }
-{ $description "Creates a new " { $link pane } " gadget." } ;
-
-HELP: write-gadget
-{ $values { "gadget" gadget } { "stream" "an output stream" } }
-{ $contract "Writes a gadget to the stream." }
-{ $notes "Not all streams support this operation." } ;
-
-{ write-gadget print-gadget gadget. } related-words
-
-HELP: print-gadget
-{ $values { "gadget" gadget } { "stream" "an output stream" } }
-{ $description "Writes a gadget to the stream, followed by a newline." }
-{ $notes "Not all streams support this operation." } ;
-
-HELP: gadget.
-{ $values { "gadget" gadget } }
-{ $description "Writes a gadget followed by a newline to " { $link output-stream } "." }
-{ $notes "Not all streams support this operation." } ;
-
-HELP: ?nl
-{ $values { "stream" pane-stream } }
-{ $description "Inserts a line break in the pane unless the current line is empty." } ;
-
-HELP: with-pane
-{ $values { "pane" pane } { "quot" quotation } }
-{ $description "Clears the pane and calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to the pane." } ;
-
-HELP: make-pane
-{ $values { "quot" quotation } { "gadget" "a new " { $link gadget } } }
-{ $description "Calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to a new pane. The output area of the new pane is output on the stack after the quotation returns. The pane itself is not output." } ;
-
-HELP: <scrolling-pane>
-{ $values { "pane" "a new " { $link pane } } }
-{ $description "Creates a new " { $link pane } " gadget which scrolls any scroll pane containing it to the bottom on output. behaving much like a terminal or logger." } ;
-
-HELP: <pane-control>
-{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( value -- )" } } { "pane" "a new " { $link pane } } }
-{ $description "Creates a new control delegating to a " { $link pane } ". When the value of the model changes, the value is pushed on the stack and the quotation is called using " { $link with-pane } "." } ;
-
-HELP: pane-stream
-{ $class-description "Pane streams implement the portion of the " { $link "stream-protocol" } " responsible for output of text, including full support for " { $link "styles" } ". Pane streams also support direct output of gadgets via " { $link write-gadget } " and " { $link print-gadget } ". Pane streams are created by calling " { $link <pane-stream> } "." } ;
-
-HELP: <pane-stream> ( pane -- stream )
-{ $values { "pane" pane } { "stream" "a new " { $link pane-stream } } }
-{ $description "Creates a new " { $link pane-stream } " for writing to " { $snippet "pane" } "." } ;
-
-{ with-pane make-pane } related-words
-
-ARTICLE: "ui.gadgets.panes" "Pane gadgets"
-"A pane displays formatted text."
-{ $subsection pane }
-{ $subsection <pane> }
-{ $subsection <scrolling-pane> }
-{ $subsection <pane-control> }
-"Panes are written to by creating a special output stream:"
-{ $subsection pane-stream }
-{ $subsection <pane-stream> }
-"In addition to the stream output words (" { $link "stream-protocol" } ", pane streams can have gadgets written to them:"
-{ $subsection write-gadget }
-{ $subsection print-gadget }
-{ $subsection gadget. }
-"The " { $link gadget. } " word is useful for interactive debugging of gadgets in the listener."
-$nl
-"There are a few combinators for working with panes:"
-{ $subsection with-pane }
-{ $subsection make-pane } ;
-
-ABOUT: "ui.gadgets.panes"
+++ /dev/null
-IN: ui.gadgets.panes.tests
-USING: alien ui.gadgets.panes ui.gadgets namespaces
-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 ;
-
-: #children "pane" get gadget-children length ;
-
-[ ] [ <pane> "pane" set ] unit-test
-
-[ ] [ #children "num-children" set ] unit-test
-
-[ ] [
- "pane" get <pane-stream> [ 10000 [ . ] each ] with-output-stream*
-] unit-test
-
-[ t ] [ #children "num-children" get = ] unit-test
-
-: test-gadget-text
- dup make-pane gadget-text dup print "======" print
- swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
-
-[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
-[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
-[ t ] [
- [
- H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting
- ] test-gadget-text
-] unit-test
-[ t ] [
- [
- H{ { wrap-margin 100 } } [
- H{ } [
- "hello" pprint
- ] with-style
- ] with-nesting
- ] test-gadget-text
-] unit-test
-[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
-[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
-[ t ] [ [ \ = see ] test-gadget-text ] unit-test
-[ t ] [ [ \ = help ] test-gadget-text ] unit-test
-
-[ t ] [
- [
- title-style get [
- "Hello world" write
- ] with-style
- ] test-gadget-text
-] unit-test
-
-
-[ t ] [
- [
- title-style get [
- "Hello world" write
- ] with-nesting
- ] test-gadget-text
-] unit-test
-
-[ t ] [
- [
- title-style get [
- title-style get [
- "Hello world" write
- ] with-nesting
- ] with-style
- ] test-gadget-text
-] unit-test
-
-[ t ] [
- [
- title-style get [
- title-style get [
- [ "Hello world" write ] ($block)
- ] with-nesting
- ] with-style
- ] test-gadget-text
-] unit-test
-
-ARTICLE: "test-article-1" "This is a test article"
-"Hello world, how are you today." ;
-
-[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
-
-[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
-
-ARTICLE: "test-article-2" "This is a test article"
-"Hello world, how are you today."
-{ $table { "a" "b" } { "c" "d" } } ;
-
-[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
-
-<pane> [ \ = see ] with-pane
-<pane> [ \ = help ] with-pane
-
-[ ] [
- \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 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 ui.gadgets.incremental ui.gadgets.packs
- ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
- hashtables io kernel namespaces sequences io.styles strings
- quotations math opengl combinators math.vectors
- sorting splitting io.streams.nested assocs
- ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
- ui.gadgets.grid-lines classes.tuple models continuations
- destructors accessors math.geometry.rect ;
-
-IN: ui.gadgets.panes
-
-TUPLE: pane < pack
- output current prototype scrolls?
- selection-color caret mark selecting? ;
-
-: clear-selection ( pane -- pane ) f >>caret f >>mark ;
-
-: add-output ( pane current -- pane ) [ >>output ] [ add-gadget ] bi ;
-: add-current ( pane current -- pane ) [ >>current ] [ add-gadget ] bi ;
-
-: prepare-line ( pane -- pane )
- clear-selection
- dup prototype>> clone add-current ;
-
-: pane-caret&mark ( pane -- caret mark ) [ caret>> ] [ mark>> ] bi ;
-
-: selected-children ( pane -- seq )
- [ pane-caret&mark sort-pair ] keep gadget-subtree ;
-
-M: pane gadget-selection? pane-caret&mark and ;
-
-M: pane gadget-selection ( pane -- string/f ) selected-children gadget-text ;
-
-: pane-clear ( pane -- )
- clear-selection
- [ pane-output clear-incremental ]
- [ pane-current clear-gadget ]
- bi ;
-
-: new-pane ( class -- pane )
- new-gadget
- { 0 1 } >>orientation
- <shelf> >>prototype
- <incremental> add-output
- prepare-line
- selection-color >>selection-color ;
-
-: <pane> ( -- pane ) pane new-pane ;
-
-GENERIC: draw-selection ( loc obj -- )
-
-: if-fits ( rect quot -- )
- >r clip get over intersects? r> [ drop ] if ; inline
-
-M: gadget draw-selection ( loc gadget -- )
- swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;
-
-M: node draw-selection ( loc node -- )
- 2dup node-value swap offset-rect [
- drop 2dup
- [ node-value rect-loc v+ ] keep
- node-children [ draw-selection ] with each
- ] if-fits 2drop ;
-
-M: pane draw-gadget*
- dup gadget-selection? [
- dup pane-selection-color set-color
- origin get over rect-loc v- swap selected-children
- [ draw-selection ] with each
- ] [
- drop
- ] if ;
-
-: scroll-pane ( pane -- )
- dup pane-scrolls? [ scroll>bottom ] [ drop ] if ;
-
-TUPLE: pane-stream pane ;
-
-C: <pane-stream> pane-stream
-
-: smash-line ( current -- gadget )
- dup gadget-children {
- { [ dup empty? ] [ 2drop "" <label> ] }
- { [ dup length 1 = ] [ nip first ] }
- [ drop ]
- } cond ;
-
-: smash-pane ( pane -- gadget ) pane-output smash-line ;
-
-: pane-nl ( pane -- pane )
- dup pane-current dup unparent smash-line
- over pane-output add-incremental
- prepare-line ;
-
-: pane-write ( pane seq -- )
- [ pane-nl ]
- [ over pane-current stream-write ]
- interleave drop ;
-
-: pane-format ( style pane seq -- )
- [ pane-nl ]
- [ 2over pane-current stream-format ]
- interleave 2drop ;
-
-GENERIC: write-gadget ( gadget stream -- )
-
-M: pane-stream write-gadget ( gadget pane-stream -- )
- pane>> current>> swap add-gadget drop ;
-
-M: style-stream write-gadget
- stream>> write-gadget ;
-
-: print-gadget ( gadget stream -- )
- tuck write-gadget stream-nl ;
-
-: gadget. ( gadget -- )
- output-stream get print-gadget ;
-
-: ?nl ( stream -- )
- dup pane-stream-pane pane-current gadget-children empty?
- [ dup stream-nl ] unless drop ;
-
-: with-pane ( pane quot -- )
- over scroll>top
- over pane-clear >r <pane-stream> r>
- over >r with-output-stream* r> ?nl ; inline
-
-: make-pane ( quot -- gadget )
- <pane> [ swap with-pane ] keep smash-pane ; inline
-
-: <scrolling-pane> ( -- pane )
- <pane> t over set-pane-scrolls? ;
-
-TUPLE: pane-control < pane quot ;
-
-M: pane-control model-changed ( model pane-control -- )
- [ value>> ] [ dup quot>> ] bi* with-pane ;
-
-: <pane-control> ( model quot -- pane )
- pane-control new-pane
- swap >>quot
- swap >>model ;
-
-: do-pane-stream ( pane-stream quot -- )
- >r pane-stream-pane r> keep scroll-pane ; inline
-
-M: pane-stream stream-nl
- [ pane-nl drop ] do-pane-stream ;
-
-M: pane-stream stream-write1
- [ pane-current stream-write1 ] do-pane-stream ;
-
-M: pane-stream stream-write
- [ swap string-lines pane-write ] do-pane-stream ;
-
-M: pane-stream stream-format
- [ rot string-lines pane-format ] do-pane-stream ;
-
-M: pane-stream dispose drop ;
-
-M: pane-stream stream-flush drop ;
-
-M: pane-stream make-span-stream
- swap <style-stream> <ignore-close-stream> ;
-
-! Character styles
-
-: apply-style ( style gadget key quot -- style gadget )
- >r pick at r> when* ; inline
-
-: apply-foreground-style ( style gadget -- style gadget )
- foreground [ over set-label-color ] apply-style ;
-
-: apply-background-style ( style gadget -- style gadget )
- background [ solid-interior ] apply-style ;
-
-: specified-font ( style -- font )
- [ font swap at "monospace" or ] keep
- [ font-style swap at plain or ] keep
- font-size swap at 12 or 3array ;
-
-: apply-font-style ( style gadget -- style gadget )
- over specified-font over set-label-font ;
-
-: apply-presentation-style ( style gadget -- style gadget )
- presented [ <presentation> ] apply-style ;
-
-: style-label ( style gadget -- gadget )
- apply-foreground-style
- apply-background-style
- apply-font-style
- apply-presentation-style
- nip ; inline
-
-: <styled-label> ( style text -- gadget )
- <label> style-label ;
-
-! Paragraph styles
-
-: apply-wrap-style ( style pane -- style pane )
- wrap-margin [
- 2dup <paragraph> >>prototype drop
- <paragraph> >>current
- ] apply-style ;
-
-: apply-border-color-style ( style gadget -- style gadget )
- border-color [ solid-boundary ] apply-style ;
-
-: 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 ] curry >>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 ;
-
-: new-nested-pane-stream ( style parent class -- stream )
- new
- swap >>parent
- swap <pane> apply-wrap-style [ >>style ] [ >>pane ] bi* ;
- inline
-
-: unnest-pane-stream ( stream -- child parent )
- dup ?nl
- dup style>>
- over pane>> smash-pane style-pane
- swap parent>> ;
-
-TUPLE: pane-block-stream < nested-pane-stream ;
-
-M: pane-block-stream dispose
- unnest-pane-stream write-gadget ;
-
-M: pane-stream make-block-stream
- pane-block-stream new-nested-pane-stream ;
-
-! Tables
-: apply-table-gap-style ( style grid -- style grid )
- table-gap [ over set-grid-gap ] apply-style ;
-
-: apply-table-border-style ( style grid -- style grid )
- table-border [ <grid-lines> over set-gadget-boundary ]
- apply-style ;
-
-: styled-grid ( style grid -- grid )
- <grid>
- f over set-grid-fill?
- apply-table-gap-style
- apply-table-border-style
- nip ;
-
-TUPLE: pane-cell-stream < nested-pane-stream ;
-
-M: pane-cell-stream dispose ?nl ;
-
-M: pane-stream make-cell-stream
- pane-cell-stream new-nested-pane-stream ;
-
-M: pane-stream stream-write-table
- >r
- swap [ [ pane-stream-pane smash-pane ] map ] map
- styled-grid
- r> print-gadget ;
-
-! Stream utilities
-M: pack dispose drop ;
-
-M: paragraph dispose drop ;
-
-: gadget-write ( string gadget -- )
- over empty?
- [ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
-
-M: pack stream-write gadget-write ;
-
-: gadget-bl ( style stream -- )
- >r " " <word-break-gadget> style-label r> swap add-gadget drop ;
-
-M: paragraph stream-write
- swap " " split
- [ H{ } over gadget-bl ] [ over gadget-write ] interleave
- drop ;
-
-: gadget-write1 ( char gadget -- )
- >r 1string r> stream-write ;
-
-M: pack stream-write1 gadget-write1 ;
-
-M: paragraph stream-write1
- over CHAR: \s =
- [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
-
-: gadget-format ( string style stream -- )
- pick empty?
- [ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
-
-M: pack stream-format
- gadget-format ;
-
-M: paragraph stream-format
- presented pick at [
- gadget-format
- ] [
- rot " " split
- [ 2dup gadget-bl ]
- [ 2over gadget-format ] interleave
- 2drop
- ] if ;
-
-: caret>mark ( pane -- pane )
- dup caret>> >>mark
- dup relayout-1 ;
-
-GENERIC: sloppy-pick-up* ( loc gadget -- n )
-
-M: pack sloppy-pick-up* ( loc gadget -- n )
- [ orientation>> ] [ children>> ] bi (fast-children-on) ;
-
-M: gadget sloppy-pick-up*
- gadget-children [ inside? ] with find-last drop ;
-
-M: f sloppy-pick-up*
- 2drop f ;
-
-: wet-and-sloppy ( loc gadget n -- newloc newgadget )
- swap nth-gadget [ rect-loc v- ] keep ;
-
-: sloppy-pick-up ( loc gadget -- path )
- 2dup sloppy-pick-up* dup
- [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
- [ 3drop { } ]
- if ;
-
-: move-caret ( pane -- pane )
- dup hand-rel
- over sloppy-pick-up
- over set-pane-caret
- dup relayout-1 ;
-
-: begin-selection ( pane -- )
- move-caret f swap set-pane-mark ;
-
-: extend-selection ( pane -- )
- hand-moved? [
- dup selecting?>> [
- move-caret
- ] [
- dup hand-clicked get child? [
- t >>selecting?
- dup hand-clicked set-global
- move-caret
- caret>mark
- ] when
- ] if
- dup dup pane-caret gadget-at-path scroll>gadget
- ] when drop ;
-
-: end-selection ( pane -- )
- f >>selecting?
- hand-moved? [
- [ com-copy-selection ] [ request-focus ] bi
- ] [
- relayout-1
- ] if ;
-
-: select-to-caret ( pane -- )
- dup pane-mark [ caret>mark ] unless
- move-caret
- dup request-focus
- com-copy-selection ;
-
-pane H{
- { T{ button-down } [ begin-selection ] }
- { T{ button-down f { S+ } 1 } [ select-to-caret ] }
- { T{ button-up f { S+ } 1 } [ drop ] }
- { T{ button-up } [ end-selection ] }
- { T{ drag } [ extend-selection ] }
- { T{ copy-action } [ com-copy ] }
-} set-gestures
+++ /dev/null
-Pane gadgets display formatted stream output
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
-namespaces sequences math.order math.geometry.rect ;
-IN: ui.gadgets.paragraphs
-
-! A word break gadget
-TUPLE: word-break-gadget < label ;
-
-: <word-break-gadget> ( text -- gadget )
- word-break-gadget new-label ;
-
-M: word-break-gadget draw-gadget* drop ;
-
-! A gadget that arranges its children in a word-wrap style.
-TUPLE: paragraph < gadget margin ;
-
-: <paragraph> ( margin -- gadget )
- paragraph new-gadget
- { 1 0 } over set-gadget-orientation
- [ set-paragraph-margin ] keep ;
-
-SYMBOL: x SYMBOL: max-x
-
-SYMBOL: y SYMBOL: max-y
-
-SYMBOL: line-height
-
-SYMBOL: margin
-
-: overrun? ( width -- ? ) x get + margin get > ;
-
-: zero-vars ( seq -- ) [ 0 swap set ] each ;
-
-: wrap-line ( -- )
- line-height get y +@
- { x line-height } zero-vars ;
-
-: wrap-pos ( -- pos ) x get y get 2array ; inline
-
-: advance-x ( x -- )
- x +@
- x get max-x [ max ] change ;
-
-: advance-y ( y -- )
- dup line-height [ max ] change
- y get + max-y [ max ] change ;
-
-: wrap-step ( quot child -- )
- dup pref-dim [
- over word-break-gadget? [
- dup first overrun? [ wrap-line ] when
- ] unless drop wrap-pos rot call
- ] keep first2 advance-y advance-x ; inline
-
-: wrap-dim ( -- dim ) max-x get max-y get 2array ;
-
-: init-wrap ( paragraph -- )
- paragraph-margin margin set
- { x max-x y max-y line-height } zero-vars ;
-
-: do-wrap ( paragraph quot -- dim )
- [
- swap dup init-wrap
- [ wrap-step ] with each-child wrap-dim
- ] with-scope ; inline
-
-M: paragraph pref-dim*
- [ 2drop ] do-wrap ;
-
-M: paragraph layout*
- [ swap dup prefer set-rect-loc ] do-wrap drop ;
+++ /dev/null
-Paragraph gadgets lay out their children from left to right, wrapping at a fixed margin
+++ /dev/null
-
-USING: kernel quotations arrays sequences math math.ranges fry
- opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
- accessors ;
-
-IN: ui.gadgets.plot
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: plot < cartesian functions points ;
-
-: init-plot ( plot -- plot )
- init-cartesian
- { } >>functions
- 100 >>points ;
-
-: <plot> ( -- plot ) plot new init-plot ;
-
-: step-size ( plot -- step-size )
- [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ;
-
-: plot-range ( plot -- range )
- [ x-min>> ] [ x-max>> ] [ step-size ] tri <range> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: function function color ;
-
-GENERIC: plot-function ( plot object -- plot )
-
-M: quotation plot-function ( plot quotation -- plot )
- >r dup plot-range r> '[ dup @ 2array ] map line-strip ;
-
-M: function plot-function ( plot function -- plot )
- dup color>> dup [ >stroke-color ] [ drop ] if
- >r dup plot-range r> function>> '[ dup @ 2array ] map line-strip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ;
-
-: draw-axis ( plot -- plot )
- dup
- [ [ x-min>> ] [ drop 0 ] bi 2array ]
- [ [ x-max>> ] [ drop 0 ] bi 2array ] bi line*
- dup
- [ [ drop 0 ] [ y-min>> ] bi 2array ]
- [ [ drop 0 ] [ y-max>> ] bi 2array ] bi line* ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: ui.gadgets.slate ;
-
-M: plot draw-slate ( plot -- plot )
- 2 glLineWidth
- draw-axis
- plot-functions
- fill-mode
- 1 glLineWidth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-function ( plot function -- plot )
- over functions>> swap suffix >>functions ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: x-span ( plot -- span ) [ x-max>> ] [ x-min>> ] bi - ;
-: y-span ( plot -- span ) [ y-max>> ] [ y-min>> ] bi - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: ui.gestures ui.gadgets ;
-
-: left ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max
- dup relayout-1 ;
-
-: right ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max
- dup relayout-1 ;
-
-: down ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max
- dup relayout-1 ;
-
-: up ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zoom-in-horizontal ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi + >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi - >>x-max ;
-
-: zoom-in-vertical ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi + >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi - >>y-max ;
-
-: zoom-in ( plot -- plot )
- zoom-in-horizontal
- zoom-in-vertical
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zoom-out-horizontal ( plot -- plot )
- dup [ x-min>> ] [ x-span 1/10 * ] bi - >>x-min
- dup [ x-max>> ] [ x-span 1/10 * ] bi + >>x-max ;
-
-: zoom-out-vertical ( plot -- plot )
- dup [ y-min>> ] [ y-span 1/10 * ] bi - >>y-min
- dup [ y-max>> ] [ y-span 1/10 * ] bi + >>y-max ;
-
-: zoom-out ( plot -- plot )
- zoom-out-horizontal
- zoom-out-vertical
- dup relayout-1 ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-plot
- H{
- { T{ mouse-enter } [ request-focus ] }
- { T{ key-down f f "LEFT" } [ left drop ] }
- { T{ key-down f f "RIGHT" } [ right drop ] }
- { T{ key-down f f "DOWN" } [ down drop ] }
- { T{ key-down f f "UP" } [ up drop ] }
- { T{ key-down f f "a" } [ zoom-in drop ] }
- { T{ key-down f f "z" } [ zoom-out drop ] }
- }
-set-gestures
\ No newline at end of file
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets.buttons
-ui.gadgets.menus models ui.operations summary kernel
-ui.gadgets.worlds ui.gadgets ui.gadgets.status-bar ;
-IN: ui.gadgets.presentations
-
-HELP: presentation
-{ $class-description "A presentation is a " { $link button } " which represents an object. Left-clicking a presentation invokes the default " { $link operation } ", and right-clicking displays a menu of possible operations output by " { $link object-operations } "."
-$nl
-"Presentations are created by calling " { $link <presentation> } "."
-$nl
-"Presentations have two slots:"
-{ $list
- { { $link presentation-object } " - the object being presented." }
- { { $link presentation-hook } " - a quotation with stack effect " { $snippet "( presentation -- )" } ". The default value is " { $snippet "[ drop ]" } "." }
-} } ;
-
-HELP: invoke-presentation
-{ $values { "presentation" presentation } { "command" "a command" } }
-{ $description "Calls the " { $link presentation-hook } " and then invokes the command on the " { $link presentation-object } "." } ;
-
-{ invoke-presentation invoke-primary invoke-secondary } related-words
-
-HELP: invoke-primary
-{ $values { "presentation" presentation } }
-{ $description "Invokes the " { $link primary-operation } " associated to the " { $link presentation-object } ". This word is executed when the presentation is clicked with the left mouse button." } ;
-
-HELP: invoke-secondary
-{ $values { "presentation" presentation } }
-{ $description "Invokes the " { $link secondary-operation } " associated to the " { $link presentation-object } ". This word is executed when a list receives a " { $snippet "RET" } " key press." } ;
-
-HELP: <presentation>
-{ $values { "label" "a label" } { "object" object } { "button" "a new " { $link button } } }
-{ $description "Creates a new " { $link presentation } " derived from " { $link <roll-button> } "." }
-{ $see-also "presentations" } ;
-
-{ <button> <bevel-button> <command-button> <roll-button> <presentation> } related-words
-
-{ <commands-menu> <toolbar> operations-menu show-menu } related-words
-
-{ <status-bar> show-mouse-help show-status show-summary hide-status } related-words
-
-HELP: show-mouse-help
-{ $values { "presentation" presentation } }
-{ $description "Displays a " { $link summary } " of the " { $link presentation-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" } ")."
-{ $subsection presentation }
-{ $subsection <presentation> }
-"Presentations remember the object they are presenting; operations can be performed on the presented object. See " { $link "ui-operations" } "." ;
-
-ABOUT: "ui.gadgets.presentations"
+++ /dev/null
-IN: ui.gadgets.presentations.tests
-USING: math ui.gadgets.presentations ui.gadgets tools.test
-prettyprint ui.gadgets.buttons io io.streams.string kernel
-classes.tuple ;
-
-[ t ] [
- "Hi" \ + <presentation> [ gadget? ] is?
-] unit-test
-
-[ "+" ] [
- [
- \ + f \ pprint <command-button> dup button-quot call
- ] with-string-writer
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays accessors definitions hashtables io kernel
-prettyprint sequences strings io.styles words help math models
-namespaces quotations
-ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
-ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
-IN: ui.gadgets.presentations
-
-TUPLE: presentation < button object hook ;
-
-: invoke-presentation ( presentation command -- )
- over dup presentation-hook call
- >r presentation-object r> invoke-command ;
-
-: invoke-primary ( presentation -- )
- dup presentation-object primary-operation
- invoke-presentation ;
-
-: invoke-secondary ( presentation -- )
- dup presentation-object secondary-operation
- invoke-presentation ;
-
-: show-mouse-help ( presentation -- )
- dup presentation-object over show-summary button-update ;
-
-: <presentation> ( label object -- button )
- swap [ invoke-primary ] presentation new-button
- swap >>object
- [ drop ] >>hook
- roll-button-theme ;
-
-M: presentation ungraft*
- dup hand-gadget get-global child? [ dup hide-status ] when
- call-next-method ;
-
-: <operations-menu> ( presentation -- menu )
- dup dup presentation-hook curry
- swap presentation-object
- dup object-operations <commands-menu> ;
-
-: operations-menu ( presentation -- )
- dup <operations-menu> swap show-menu ;
-
-presentation H{
- { T{ button-down f f 3 } [ operations-menu ] }
- { T{ mouse-leave } [ dup hide-status button-update ] }
- { T{ mouse-enter } [ show-mouse-help ] }
- ! Responding to motion too allows nested presentations to
- ! display status help properly, when the mouse leaves a
- ! nested presentation and is still inside the parent, the
- ! parent doesn't receive a mouse-enter
- { T{ motion } [ show-mouse-help ] }
-} set-gestures
+++ /dev/null
-Presentations display an interactive view of an object
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports
-ui.gadgets.sliders math.geometry.rect ;
-IN: ui.gadgets.scrollers
-
-HELP: scroller
-{ $class-description "A scroller consists of a " { $link viewport } " containing a child, together with horizontal and vertical " { $link slider } " gadgets which scroll the viewport's child. Scroller gadgets also support using a mouse scroll wheel."
-$nl
-"Scroller gadgets are created by calling " { $link <scroller> } "." } ;
-
-HELP: find-scroller
-{ $values { "gadget" gadget } { "scroller/f" "a " { $link scroller } " or " { $link f } } }
-{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
-
-HELP: scroller-value
-{ $values { "scroller" scroller } { "loc" "a pair of integers" } }
-{ $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
-
-{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words
-
-HELP: <scroller>
-{ $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } }
-{ $description "Creates a new " { $link scroller } " for scrolling around " { $snippet "gadget" } "." } ;
-
-{ <viewport> <scroller> } related-words
-
-HELP: scroll
-{ $values { "scroller" scroller } { "value" "a pair of integers" } }
-{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
-
-HELP: relative-scroll-rect
-{ $values { "rect" rect } { "gadget" gadget } { "scroller" scroller } { "newrect" "a new " { $link rect } } }
-{ $description "Adjusts " { $snippet "rect" } " for the case where the gadget is not the immediate child of the scroller's viewport." } ;
-
-HELP: scroll>rect
-{ $values { "rect" rect } { "gadget" gadget } }
-{ $description "Ensures that a rectangular region relative to the top-left corner of " { $snippet "gadget" } " becomes visible in a " { $link scroller } " containing " { $snippet "gadget" } ". Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
-
-HELP: scroll>bottom
-{ $values { "gadget" gadget } }
-{ $description "Ensures that any " { $link scroller } " containing " { $snippet "gadget" } " is scrolled all the way down. Does nothing if no parent of " { $snippet "gadget" } " is a " { $link scroller } "." } ;
-
-HELP: scroll>top
-{ $values { "gadget" gadget } }
-{ $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."
-{ $subsection scroller }
-{ $subsection <scroller> }
-"Getting and setting the scroll position:"
-{ $subsection scroller-value }
-{ $subsection scroll }
-"Writing scrolling-aware gadgets:"
-{ $subsection scroll>bottom }
-{ $subsection scroll>top }
-{ $subsection scroll>rect }
-{ $subsection find-scroller } ;
-
-ABOUT: "ui.gadgets.scrollers"
+++ /dev/null
-IN: ui.gadgets.scrollers.tests
-USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
-kernel models models.compose models.range ui.gadgets.viewports
-ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
-ui.gadgets.sliders math math.vectors arrays sequences
-tools.test.ui math.geometry.rect ;
-
-[ ] [
- <gadget> "g" set
- "g" get <scroller> "s" set
-] unit-test
-
-[ { 100 200 } ] [
- { 100 200 } "g" get scroll>rect
- "s" get scroller-follows rect-loc
-] unit-test
-
-[ ] [ "s" get scroll>bottom ] unit-test
-[ t ] [ "s" get scroller-follows ] unit-test
-
-[ ] [
- <gadget> dup "g" set
- 10 1 0 100 <range> 20 1 0 100 <range> 2array <compose>
- <viewport> "v" set
-] unit-test
-
-"v" get [
- [ { 10 20 } ] [ "v" get gadget-model range-value ] unit-test
-
- [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
-] with-grafted-gadget
-
-[ ] [
- <gadget> { 100 100 } over set-rect-dim
- dup "g" set <scroller> "s" set
-] unit-test
-
-[ ] [ { 50 50 } "s" get set-rect-dim ] unit-test
-
-[ ] [ "s" get layout ] unit-test
-
-"s" get [
- [ { 34 34 } ] [ "s" get scroller-viewport rect-dim ] unit-test
-
- [ { 106 106 } ] [ "s" get scroller-viewport viewport-dim ] unit-test
-
- [ ] [ { 0 0 } "s" get scroll ] unit-test
-
- [ { 0 0 } ] [ "s" get gadget-model range-min-value ] unit-test
-
- [ { 106 106 } ] [ "s" get gadget-model range-max-value ] unit-test
-
- [ ] [ { 10 20 } "s" get scroll ] unit-test
-
- [ { 10 20 } ] [ "s" get gadget-model range-value ] unit-test
-
- [ { 10 20 } ] [ "s" get scroller-viewport gadget-model range-value ] unit-test
-
- [ { 10 20 } ] [ "g" get rect-loc vneg { 3 3 } v+ ] unit-test
-] with-grafted-gadget
-
-<gadget> { 600 400 } over set-rect-dim "g1" set
-<gadget> { 600 10 } over set-rect-dim "g2" set
-"g2" get "g1" get swap add-gadget drop
-
-"g1" get <scroller>
-{ 300 300 } over set-rect-dim
-dup layout
-"s" set
-
-[ t ] [
- 10 [
- drop
- "g2" get scroll>gadget
- "s" get layout
- "s" get scroller-value
- ] map [ { 3 0 } = ] all?
-] unit-test
-
-[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
-
-[ t ] [ "l" get find-scroller "s" get eq? ] unit-test
-[ t ] [ "l" get dup find-scroller scroller-viewport swap child? ] unit-test
-[ t ] [ "l" get find-scroller* "s" get eq? ] unit-test
-[ f ] [ "s" get scroller-viewport find-scroller* ] unit-test
-[ t ] [ "s" get @right grid-child slider? ] unit-test
-[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
-
-\ <scroller> must-infer
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gadgets ui.gadgets.viewports
-ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
-ui.gadgets.sliders ui.gestures kernel math namespaces sequences
-models models.range models.compose
-combinators math.vectors classes.tuple math.geometry.rect ;
-IN: ui.gadgets.scrollers
-
-TUPLE: scroller < frame viewport x y follows ;
-
-: find-scroller ( gadget -- scroller/f )
- [ [ scroller? ] is? ] find-parent ;
-
-: scroll-up-page ( scroller -- ) y>> -1 swap slide-by-page ;
-
-: scroll-down-page ( scroller -- ) y>> 1 swap slide-by-page ;
-
-: scroll-up-line ( scroller -- ) y>> -1 swap slide-by-line ;
-
-: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
-
-: do-mouse-scroll ( scroller -- )
- scroll-direction get-global first2
- pick scroller-y slide-by-line
- swap scroller-x slide-by-line ;
-
-scroller H{
- { T{ mouse-scroll } [ do-mouse-scroll ] }
-} set-gestures
-
-: <scroller-model> ( -- model )
- 0 0 0 0 <range> 0 0 0 0 <range> 2array <compose> ;
-
-: new-scroller ( gadget class -- scroller )
- new-frame
- t >>root?
- <scroller-model> >>model
- faint-boundary
-
- dup model>> dependencies>> first <x-slider> >>x dup x>> @bottom grid-add
- dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
-
- swap over model>> <viewport> >>viewport
- dup viewport>> @center grid-add ;
-
-: <scroller> ( gadget -- scroller ) scroller new-scroller ;
-
-: scroll ( value scroller -- )
- [
- dup scroller-viewport rect-dim { 0 0 }
- rot scroller-viewport viewport-dim 4array flip
- ] keep
- 2dup control-value = [ 2drop ] [ set-control-value ] if ;
-
-: rect-min ( rect1 rect2 -- rect )
- >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
-
-: (scroll>rect) ( rect scroller -- )
- [
- scroller-value vneg offset-rect
- viewport-gap offset-rect
- ] keep
- [ scroller-viewport rect-min ] keep
- [
- scroller-viewport 2rect-extent
- >r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
- ] keep dup scroller-value rot v+ swap scroll ;
-
-: relative-scroll-rect ( rect gadget scroller -- newrect )
- viewport>> gadget-child relative-loc offset-rect ;
-
-: find-scroller* ( gadget -- scroller )
- dup find-scroller dup [
- 2dup scroller-viewport gadget-child
- swap child? [ nip ] [ 2drop f ] if
- ] [
- 2drop f
- ] if ;
-
-: scroll>rect ( rect gadget -- )
- dup find-scroller* dup [
- [ relative-scroll-rect ] keep
- [ set-scroller-follows ] keep
- relayout
- ] [
- 3drop
- ] if ;
-
-: (scroll>gadget) ( gadget scroller -- )
- >r { 0 0 } over pref-dim <rect> swap r>
- [ relative-scroll-rect ] keep
- (scroll>rect) ;
-
-: scroll>gadget ( gadget -- )
- dup find-scroller* dup [
- [ set-scroller-follows ] keep
- relayout
- ] [
- 2drop
- ] if ;
-
-: (scroll>bottom) ( scroller -- )
- dup scroller-viewport viewport-dim { 0 1 } v* swap scroll ;
-
-: scroll>bottom ( gadget -- )
- find-scroller [
- t over set-scroller-follows relayout-1
- ] when* ;
-
-: scroll>top ( gadget -- )
- <zero-rect> swap scroll>rect ;
-
-GENERIC: update-scroller ( scroller follows -- )
-
-M: t update-scroller drop (scroll>bottom) ;
-
-M: gadget update-scroller swap (scroll>gadget) ;
-
-M: rect update-scroller swap (scroll>rect) ;
-
-M: f update-scroller drop dup scroller-value swap scroll ;
-
-M: scroller layout*
- dup call-next-method
- dup scroller-follows
- [ update-scroller ] 2keep
- swap set-scroller-follows ;
-
-M: scroller focusable-child*
- scroller-viewport ;
-
-M: scroller model-changed
- nip f swap set-scroller-follows ;
-
-TUPLE: limited-scroller < scroller fixed-dim ;
-
-: <limited-scroller> ( gadget dim -- scroller )
- >r limited-scroller new-scroller r> >>fixed-dim ;
-
-M: limited-scroller pref-dim*
- fixed-dim>> ;
+++ /dev/null
-Scrollers display a user-chosen portion of a child which may have arbitrary dimensions
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel namespaces opengl ui.render ui.gadgets accessors ;
-
-IN: ui.gadgets.slate
-
-TUPLE: slate < gadget action pdim graft ungraft ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-slate ( slate -- slate )
- init-gadget
- [ ] >>action
- { 200 200 } >>pdim
- [ ] >>graft
- [ ] >>ungraft ;
-
-: <slate> ( action -- slate )
- slate new
- init-slate
- swap >>action ;
-
-M: slate pref-dim* ( slate -- dim ) pdim>> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: combinators arrays sequences math math.geometry
- opengl.gl ui.gadgets.worlds ;
-
-: screen-y* ( gadget -- loc )
- {
- [ find-world height ]
- [ screen-loc second ]
- [ height ]
- }
- cleave
- + - ;
-
-: screen-loc* ( gadget -- loc )
- {
- [ screen-loc first ]
- [ screen-y* ]
- }
- cleave
- 2array ;
-
-: setup-viewport ( gadget -- gadget )
- dup
- {
- [ screen-loc* ]
- [ dim>> ]
- }
- cleave
- gl-viewport ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: default-coordinate-system ( gadget -- gadget )
- dup
- {
- [ drop 0 ]
- [ width 1 - ]
- [ height 1 - ]
- [ drop 0 ]
- }
- cleave
- -1 1
- glOrtho ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate graft* ( slate -- ) graft>> call ;
-M: slate ungraft* ( slate -- ) ungraft>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: establish-coordinate-system ( gadget -- gadget )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate establish-coordinate-system ( slate -- slate )
- default-coordinate-system ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: draw-slate ( slate -- slate )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-slate ( slate -- slate ) dup action>> call ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: slate draw-gadget* ( slate -- )
-
- GL_PROJECTION glMatrixMode glPushMatrix glLoadIdentity
-
- establish-coordinate-system
-
- GL_MODELVIEW glMatrixMode glPushMatrix glLoadIdentity
-
- setup-viewport
-
- draw-slate
-
- GL_PROJECTION glMatrixMode glPopMatrix glLoadIdentity
- GL_MODELVIEW glMatrixMode glPopMatrix glLoadIdentity
-
- dup
- find-world
- ! The world coordinate system is a little wacky:
- dup { [ drop 0 ] [ width ] [ height ] [ drop 0 ] } cleave -1 1 glOrtho
- setup-viewport
- drop
- drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets models models.range ;
-IN: ui.gadgets.sliders
-
-HELP: elevator
-{ $class-description "An elevator is the part of a " { $link slider } " between the up/down arrow buttons, where a " { $link thumb } " may be moved up and down." } ;
-
-HELP: find-elevator
-{ $values { "gadget" gadget } { "elevator/f" "an " { $link elevator } " or " { $link f } } }
-{ $description "Finds the first parent of " { $snippet "gadget" } " which is an " { $link elevator } ". Outputs " { $link f } " if the gadget is not contained in an " { $link elevator } "." } ;
-
-HELP: slider
-{ $class-description "A slider is a control for graphically manipulating a " { $link "models-range" } "."
-$nl
-"Sliders are created by calling " { $link <x-slider> } " or " { $link <y-slider> } "." } ;
-
-HELP: find-slider
-{ $values { "gadget" gadget } { "slider/f" "a " { $link slider } " or " { $link f } } }
-{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link slider } ". Outputs " { $link f } " if the gadget is not contained in a " { $link slider } "." } ;
-
-HELP: thumb
-{ $class-description "A thumb is the gadget contained in a " { $link slider } "'s " { $link elevator } " which indicates the current scroll position and can be dragged up and down with the mouse." } ;
-
-HELP: slide-by
-{ $values { "amount" "an integer" } { "slider" slider } }
-{ $description "Adds the amount (which may be positive or negative) to the slider's current position." } ;
-
-HELP: slide-by-page
-{ $values { "amount" "an integer" } { "slider" slider } }
-{ $description "Adds the amount multiplied by " { $link slider-page } " to the slider's current position." } ;
-
-HELP: slide-by-line
-{ $values { "amount" "an integer" } { "slider" slider } }
-{ $description "Adds the amount multiplied by " { $link slider-line } " to the slider's current position." } ;
-
-HELP: <slider>
-{ $values { "range" range } { "orientation" "an orientation specifier" } { "slider" "a new " { $link slider } } }
-{ $description "Internal word for constructing sliders." }
-{ $notes "This does not build a complete slider, and user code should call " { $link <x-slider> } " or " { $link <y-slider> } " instead." } ;
-
-HELP: <x-slider>
-{ $values { "range" range } { "slider" slider } }
-{ $description "Creates a new horizontal " { $link slider } "." } ;
-
-HELP: <y-slider>
-{ $values { "range" range } { "slider" slider } }
-{ $description "Creates a new vertical " { $link slider } "." } ;
-
-{ <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."
-{ $subsection slider }
-{ $subsection <x-slider> }
-{ $subsection <y-slider> }
-"Changing slider values:"
-{ $subsection slide-by }
-{ $subsection slide-by-line }
-{ $subsection slide-by-page }
-"Since sliders are controls the value can be get and set by calling " { $link gadget-model } "." ;
-
-ABOUT: "ui.gadgets.sliders"
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
-ui.gadgets.frames ui.gadgets.grids math.order
-ui.gadgets.theme ui.render kernel math namespaces sequences
-vectors models models.range math.vectors math.functions
-quotations colors math.geometry.rect ;
-IN: ui.gadgets.sliders
-
-TUPLE: elevator < gadget direction ;
-
-: find-elevator ( gadget -- elevator/f ) [ elevator? ] find-parent ;
-
-TUPLE: slider < frame elevator thumb saved line ;
-
-: find-slider ( gadget -- slider/f ) [ slider? ] find-parent ;
-
-: elevator-length ( slider -- n )
- [ elevator>> dim>> ] [ orientation>> ] bi v. ;
-
-: min-thumb-dim 15 ;
-
-: slider-value ( gadget -- n ) gadget-model range-value >fixnum ;
-: slider-page ( gadget -- n ) gadget-model range-page-value ;
-: slider-max ( gadget -- n ) gadget-model range-max-value ;
-: slider-max* ( gadget -- n ) gadget-model range-max-value* ;
-
-: thumb-dim ( slider -- h )
- dup slider-page over slider-max 1 max / 1 min
- over elevator-length * min-thumb-dim max
- over slider-elevator rect-dim
- rot gadget-orientation v. min ;
-
-: slider-scale ( slider -- n )
- #! A scaling factor such that if x is a slider co-ordinate,
- #! x*n is the screen position of the thumb, and conversely
- #! for x/n. The '1 max' calls avoid division by zero.
- dup elevator-length over thumb-dim - 1 max
- swap slider-max* 1 max / ;
-
-: slider>screen ( m scale -- n ) slider-scale * ;
-: screen>slider ( m scale -- n ) slider-scale / ;
-
-M: slider model-changed nip slider-elevator relayout-1 ;
-
-TUPLE: thumb < gadget ;
-
-: begin-drag ( thumb -- )
- find-slider dup slider-value swap set-slider-saved ;
-
-: do-drag ( thumb -- )
- find-slider drag-loc over gadget-orientation v.
- over screen>slider swap [ slider-saved + ] keep
- gadget-model set-range-value ;
-
-thumb H{
- { T{ button-down } [ begin-drag ] }
- { T{ button-up } [ drop ] }
- { T{ drag } [ do-drag ] }
-} set-gestures
-
-: thumb-theme ( thumb -- thumb )
- plain-gradient >>interior
- faint-boundary ; inline
-
-: <thumb> ( vector -- thumb )
- thumb new-gadget
- swap >>orientation
- t >>root?
- thumb-theme ;
-
-: slide-by ( amount slider -- ) gadget-model move-by ;
-
-: slide-by-page ( amount slider -- ) gadget-model move-by-page ;
-
-: compute-direction ( elevator -- -1/1 )
- dup find-slider swap hand-click-rel
- over gadget-orientation v.
- over screen>slider
- swap slider-value - sgn ;
-
-: elevator-hold ( elevator -- )
- dup elevator-direction swap find-slider slide-by-page ;
-
-: elevator-click ( elevator -- )
- dup compute-direction over set-elevator-direction
- elevator-hold ;
-
-elevator H{
- { T{ drag } [ elevator-hold ] }
- { T{ button-down } [ elevator-click ] }
-} set-gestures
-
-: <elevator> ( vector -- elevator )
- elevator new-gadget
- swap >>orientation
- lowered-gradient >>interior ;
-
-: (layout-thumb) ( slider n -- n thumb )
- over gadget-orientation n*v swap slider-thumb ;
-
-: thumb-loc ( slider -- loc )
- dup slider-value swap slider>screen ;
-
-: layout-thumb-loc ( slider -- )
- dup thumb-loc (layout-thumb)
- >r [ floor ] map r> set-rect-loc ;
-
-: layout-thumb-dim ( slider -- )
- dup dup thumb-dim (layout-thumb) >r
- >r dup rect-dim r>
- rot gadget-orientation set-axis [ ceiling ] map
- r> (>>dim) ;
-
-: layout-thumb ( slider -- )
- dup layout-thumb-loc layout-thumb-dim ;
-
-M: elevator layout*
- find-slider layout-thumb ;
-
-: slide-by-line ( amount slider -- )
- [ slider-line * ] keep slide-by ;
-
-: <slide-button> ( vector polygon amount -- button )
- >r gray swap <polygon-gadget> r>
- [ swap find-slider slide-by-line ] curry <repeat-button>
- [ set-gadget-orientation ] keep ;
-
-: elevator, ( gadget orientation -- gadget )
- tuck <elevator> >>elevator
- swap <thumb> >>thumb
- dup elevator>> over thumb>> add-gadget
- @center grid-add ;
-
-: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
-: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
-: <up-button> ( -- button ) { 1 0 } arrow-up -1 <slide-button> ;
-: <down-button> ( -- button ) { 1 0 } arrow-down 1 <slide-button> ;
-
-: <slider> ( range orientation -- slider )
- slider new-frame
- swap >>orientation
- swap >>model
- 32 >>line ;
-
-: <x-slider> ( range -- slider )
- { 1 0 } <slider>
- <left-button> @left grid-add
- { 0 1 } elevator,
- <right-button> @right grid-add ;
-
-: <y-slider> ( range -- slider )
- { 0 1 } <slider>
- <up-button> @top grid-add
- { 1 0 } elevator,
- <down-button> @bottom grid-add ;
-
-M: slider pref-dim*
- dup call-next-method
- swap gadget-orientation [ 40 v*n ] keep
- set-axis ;
+++ /dev/null
-Slider gadgets provide a graphical view of an integer-valued model
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: ui.gadgets.slots.tests
-USING: assocs ui.gadgets.slots tools.test refs ;
-
-\ <editable-slot> must-infer
-
-[ t ] [ { 1 2 3 } 2 <value-ref> <slot-editor> slot-editor? ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 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 ;
-IN: ui.gadgets.slots
-
-TUPLE: update-object ;
-
-TUPLE: update-slot ;
-
-TUPLE: edit-slot ;
-
-TUPLE: slot-editor < track ref text ;
-
-: revert ( slot-editor -- )
- dup slot-editor-ref get-ref unparse-use
- swap slot-editor-text set-editor-string ;
-
-\ revert H{
- { +description+ "Revert any uncomitted changes." }
-} define-command
-
-GENERIC: finish-editing ( slot-editor ref -- )
-
-M: key-ref finish-editing
- drop T{ update-object } swap send-gesture drop ;
-
-M: value-ref finish-editing
- drop T{ update-slot } swap send-gesture drop ;
-
-: slot-editor-value ( slot-editor -- object )
- slot-editor-text control-value parse-fresh ;
-
-: commit ( slot-editor -- )
- dup slot-editor-text control-value parse-fresh first
- over slot-editor-ref set-ref
- dup slot-editor-ref finish-editing ;
-
-\ commit H{
- { +description+ "Parse the object being edited, and store the result back into the edited slot." }
-} define-command
-
-: com-eval ( slot-editor -- )
- [ slot-editor-text editor-string eval ] keep
- [ slot-editor-ref set-ref ] keep
- dup slot-editor-ref finish-editing ;
-
-\ com-eval H{
- { +listener+ t }
- { +description+ "Parse code which evaluates to an object, and store the result back into the edited slot." }
-} define-command
-
-: delete ( slot-editor -- )
- dup slot-editor-ref delete-ref
- T{ update-object } swap send-gesture drop ;
-
-\ delete H{
- { +description+ "Delete the slot and close the slot editor." }
-} define-command
-
-: close ( slot-editor -- )
- T{ update-slot } swap send-gesture drop ;
-
-\ close H{
- { +description+ "Close the slot editor without saving changes." }
-} define-command
-
-: <slot-editor> ( ref -- gadget )
- { 0 1 } slot-editor new-track
- swap >>ref
- dup <toolbar> f track-add
- <source-editor> >>text
- dup text>> <scroller> 1 track-add
- dup revert ;
-
-M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
-
-M: slot-editor focusable-child* text>> ;
-
-slot-editor "toolbar" f {
- { T{ key-down f { C+ } "RET" } commit }
- { T{ key-down f { S+ C+ } "RET" } com-eval }
- { f revert }
- { 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 send-gesture drop ]
- <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
-Slot editor gadgets are used to implement the UI inspector
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax models
-ui.gadgets ui.gadgets.worlds ;
-IN: ui.gadgets.status-bar
-
-HELP: <status-bar>
-{ $values { "model" model } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a new " { $link gadget } " displaying the model value, which must be a string or " { $link f } "." }
-{ $notes "If the " { $snippet "model" } " is " { $link world-status } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors models models.delay models.filter
-sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
-ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
-IN: ui.gadgets.status-bar
-
-: <status-bar> ( model -- gadget )
- 1/10 seconds <delay> [ "" like ] <filter> <label-control>
- reverse-video-theme
- t >>root? ;
-
-: open-status-window ( gadget title -- )
- f <model> [ <world> ] keep
- <status-bar> f track-add
- open-world-window ;
-
-: show-summary ( object gadget -- )
- >r [ summary ] [ "" ] if* r> show-status ;
+++ /dev/null
-Status bar gadgets display mouse-over help for other gadgets
+++ /dev/null
-Gadget hierarchy and layout management
+++ /dev/null
-William Schlieper
\ No newline at end of file
+++ /dev/null
-Tabbed windows
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
- hashtables models models.range models.compose combinators\r
- ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
- ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
-\r
-IN: ui.gadgets.tabs\r
-\r
-TUPLE: tabbed < frame names toggler content ;\r
-\r
-DEFER: (del-page)\r
-\r
-:: add-toggle ( model n name toggler -- )\r
- <frame>\r
- n name toggler parent>> '[ , , , (del-page) ] "X" swap <bevel-button>\r
- @right grid-add\r
- n model name <toggle-button> @center grid-add\r
- toggler swap add-gadget drop ;\r
-\r
-: redo-toggler ( tabbed -- )\r
- [ names>> ] [ model>> ] [ toggler>> ] tri\r
- [ clear-gadget ] keep\r
- [ [ length ] keep ] 2dip\r
- '[ , _ _ , add-toggle ] 2each ;\r
-\r
-: refresh-book ( tabbed -- )\r
- model>> [ ] change-model ;\r
-\r
-: (del-page) ( n name tabbed -- )\r
- { [ [ remove ] change-names redo-toggler ]\r
- [ dupd [ names>> length ] [ model>> ] bi\r
- [ [ = ] keep swap [ 1- ] when\r
- [ < ] keep swap [ 1- ] when ] change-model ]\r
- [ content>> nth-gadget unparent ]\r
- [ refresh-book ]\r
- } cleave ;\r
-\r
-: add-page ( page name tabbed -- )\r
- [ names>> push ] 2keep\r
- [ [ model>> swap ]\r
- [ names>> length 1 - swap ]\r
- [ toggler>> ] tri add-toggle ]\r
- [ content>> swap add-gadget drop ]\r
- [ refresh-book ] tri ;\r
-\r
-: del-page ( name tabbed -- )\r
- [ names>> index ] 2keep (del-page) ;\r
-\r
-: <tabbed> ( assoc -- tabbed )\r
- tabbed new-frame\r
- 0 <model> >>model\r
- <pile> 1 >>fill >>toggler\r
- dup toggler>> @left grid-add\r
- swap\r
- [ keys >vector >>names ]\r
- [ values over model>> <book> >>content dup content>> @center grid-add ]\r
- bi\r
- dup redo-toggler ;\r
- \r
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Common colors and gradients used by the UI
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! Copyright (C) 2006, 2007 Alex Chapman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors accessors ;
-IN: ui.gadgets.theme
-
-: solid-interior ( gadget color -- gadget )
- <solid> >>interior ; inline
-
-: solid-boundary ( gadget color -- gadget )
- <solid> >>boundary ; inline
-
-: faint-boundary ( gadget -- gadget )
- gray solid-boundary ; inline
-
-: selection-color ( -- color ) light-purple ;
-
-: plain-gradient
- T{ gradient f {
- T{ gray f 0.94 1.0 }
- T{ gray f 0.83 1.0 }
- T{ gray f 0.83 1.0 }
- T{ gray f 0.62 1.0 }
- } } ;
-
-: rollover-gradient
- T{ gradient f {
- T{ gray f 1.0 1.0 }
- T{ gray f 0.9 1.0 }
- T{ gray f 0.9 1.0 }
- T{ gray f 0.75 1.0 }
- } } ;
-
-: pressed-gradient
- T{ gradient f {
- T{ gray f 0.75 1.0 }
- T{ gray f 0.9 1.0 }
- T{ gray f 0.9 1.0 }
- T{ gray f 1.0 1.0 }
- } } ;
-
-: selected-gradient
- T{ gradient f {
- T{ gray f 0.65 1.0 }
- T{ gray f 0.8 1.0 }
- T{ gray f 0.8 1.0 }
- T{ gray f 1.0 1.0 }
- } } ;
-
-: lowered-gradient
- T{ gradient f {
- T{ gray f 0.37 1.0 }
- T{ gray f 0.43 1.0 }
- T{ gray f 0.5 1.0 }
- } } ;
-
-: sans-serif-font { "sans-serif" plain 12 } ;
-
-: monospace-font { "monospace" plain 12 } ;
+++ /dev/null
-
-USING: kernel sequences math math.order
- ui.gadgets ui.gadgets.tracks ui.gestures
- fry accessors ;
-
-IN: ui.gadgets.tiling
-
-TUPLE: tiling < track gadgets tiles first focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: init-tiling ( tiling -- tiling )
- init-track
- { 1 0 } >>orientation
- V{ } clone >>gadgets
- 2 >>tiles
- 0 >>first
- 0 >>focused ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <tiling> ( -- gadget ) tiling new init-tiling ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bounded-subseq ( seq a b -- seq )
- [ 0 max ] dip
- pick length [ min ] curry bi@
- rot
- subseq ;
-
-: tiling-gadgets-to-map ( tiling -- gadgets )
- [ gadgets>> ]
- [ first>> ]
- [ [ first>> ] [ tiles>> ] bi + ]
- tri
- bounded-subseq ;
-
-: tiling-map-gadgets ( tiling -- tiling )
- dup clear-track
- dup tiling-gadgets-to-map [ 1 track-add ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: tiling-add ( tiling gadget -- tiling )
- over gadgets>> push
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: first-gadget ( tiling -- index ) drop 0 ;
-
-: last-gadget ( tiling -- index ) gadgets>> length 1 - ;
-
-: first-viewable ( tiling -- index ) first>> ;
-
-: last-viewable ( tiling -- index ) [ first>> ] [ tiles>> ] bi + 1 - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-focused-mapped ( tiling -- tiling )
-
- dup [ focused>> ] [ first>> ] bi <
- [ dup first>> 1 - >>first ]
- [ ]
- if
-
- dup [ last-viewable ] [ focused>> ] bi <
- [ dup first>> 1 + >>first ]
- [ ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: check-focused-bounds ( tiling -- tiling )
- dup focused>> 0 max over gadgets>> length 1 - min >>focused ;
-
-: focus-prev ( tiling -- tiling )
- dup focused>> 1 - >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-: focus-next ( tiling -- tiling )
- dup focused>> 1 + >>focused
- check-focused-bounds
- make-focused-mapped
- tiling-map-gadgets
- dup request-focus ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: exchanged! ( seq a b -- )
- [ 0 max ] bi@
- pick length 1 - '[ , min ] bi@
- rot exchange ;
-
-: move-prev ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> 1 - ] [ focused>> ] tri exchanged!
- focus-prev ;
-
-: move-next ( tiling -- tiling )
- dup [ gadgets>> ] [ focused>> ] [ focused>> 1 + ] tri exchanged!
- focus-next ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: add-tile ( tiling -- tiling )
- dup tiles>> 1 + >>tiles
- tiling-map-gadgets ;
-
-: del-tile ( tiling -- tiling )
- dup tiles>> 1 - 1 max >>tiles
- tiling-map-gadgets ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-M: tiling focusable-child* ( tiling -- child/t )
- [ focused>> ] [ gadgets>> ] bi nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: tiling-shelf < tiling ;
-TUPLE: tiling-pile < tiling ;
-
-: <tiling-shelf> ( -- gadget )
- tiling-shelf new init-tiling { 1 0 } >>orientation ;
-
-: <tiling-pile> ( -- gadget )
- tiling-pile new init-tiling { 0 1 } >>orientation ;
-
-tiling-shelf
- H{
- { T{ key-down f { A+ } "LEFT" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "RIGHT" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "LEFT" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "RIGHT" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
-
-tiling-pile
- H{
- { T{ key-down f { A+ } "UP" } [ focus-prev drop ] }
- { T{ key-down f { A+ } "DOWN" } [ focus-next drop ] }
- { T{ key-down f { S+ A+ } "UP" } [ move-prev drop ] }
- { T{ key-down f { S+ A+ } "DOWN" } [ move-next drop ] }
- { T{ key-down f { C+ } "[" } [ del-tile drop ] }
- { T{ key-down f { C+ } "]" } [ add-tile drop ] }
- }
-set-gestures
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Track gadgets arrange children horizontally or vertically, giving each child a specified fraction of total available space
+++ /dev/null
-USING: ui.gadgets.packs help.markup help.syntax ui.gadgets
-arrays kernel quotations classes.tuple ;
-IN: ui.gadgets.tracks
-
-ARTICLE: "ui-track-layout" "Track layouts"
-"Track gadgets are like " { $link "ui-pack-layout" } " except each child is resized to a fixed multiple of the track's dimension."
-{ $subsection track }
-"Creating empty tracks:"
-{ $subsection <track> }
-"Adding children:"
-{ $subsection track-add } ;
-
-HELP: track
-{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
-
-HELP: <track>
-{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
-{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
-
-HELP: track-add
-{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
-{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
-
-ABOUT: "ui-track-layout"
+++ /dev/null
-USING: kernel ui.gadgets ui.gadgets.tracks tools.test
- math.geometry.rect accessors ;
-IN: ui.gadgets.tracks.tests
-
-[ { 100 100 } ] [
- { 0 1 } <track>
- <gadget> { 100 100 } >>dim 1 track-add
- pref-dim
-] unit-test
-
-[ { 100 110 } ] [
- { 0 1 } <track>
- <gadget> { 10 10 } >>dim f track-add
- <gadget> { 100 100 } >>dim 1 track-add
- pref-dim
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io kernel math namespaces
- sequences words math.vectors ui.gadgets ui.gadgets.packs
- math.geometry.rect fry ;
-
-IN: ui.gadgets.tracks
-
-TUPLE: track < pack sizes ;
-
-: normalized-sizes ( track -- seq )
- sizes>> dup sift sum '[ dup [ , / ] when ] map ;
-
-: init-track ( track -- track )
- init-gadget
- V{ } clone >>sizes
- 1 >>fill ;
-
-: new-track ( orientation class -- track )
- new
- init-track
- swap >>orientation ;
-
-: <track> ( orientation -- track ) track new-track ;
-
-: alloted-dim ( track -- dim )
- [ children>> ] [ sizes>> ] bi { 0 0 }
- [ [ drop { 0 0 } ] [ pref-dim ] if v+ ] 2reduce ;
-
-: available-dim ( track -- dim ) [ dim>> ] [ alloted-dim ] bi v- ;
-
-: track-layout ( track -- sizes )
- [ available-dim ] [ children>> ] [ normalized-sizes ] tri
- [ [ over n*v ] [ pref-dim ] ?if ] 2map nip ;
-
-M: track layout* ( track -- ) dup track-layout pack-layout ;
-
-: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
-
-: track-pref-dims-2 ( track -- dim )
- [ children>> pref-dims ] [ normalized-sizes ] bi
- [ [ v/n ] when* ] 2map
- max-dim
- [ >fixnum ] map ;
-
-M: track pref-dim* ( gadget -- dim )
- [ track-pref-dims-1 ]
- [ [ alloted-dim ] [ track-pref-dims-2 ] bi v+ ]
- [ orientation>> ]
- tri
- set-axis ;
-
-: track-add ( track gadget constraint -- track )
- pick sizes>> push add-gadget ;
-
-: track-remove ( track gadget -- track )
- dupd dup
- [
- [ swap children>> index ]
- [ unparent sizes>> ] 2bi
- delete-nth
- ]
- [ 2drop ]
- if ;
-
-: clear-track ( track -- ) V{ } clone >>sizes clear-gadget ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Viewport gadgets display a portion of a child gadget and are used to implement scrollers
+++ /dev/null
-USING: help.markup help.syntax ui.gadgets models ;
-IN: ui.gadgets.viewports
-
-HELP: viewport
-{ $class-description "A viewport is a control which positions a child gadget translated by the " { $link control-value } " vector. Viewports can be created directly by calling " { $link <viewport> } "." } ;
-
-HELP: <viewport>
-{ $values { "content" gadget } { "model" model } { "viewport" "a new " { $link viewport } } }
-{ $description "Creates a new " { $link viewport } " containing " { $snippet "content" } "." } ;
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: ui.gadgets.viewports
-USING: accessors arrays ui.gadgets ui.gadgets.borders
-kernel math namespaces sequences models math.vectors math.geometry.rect ;
-
-: viewport-gap { 3 3 } ; inline
-
-TUPLE: viewport < gadget ;
-
-: find-viewport ( gadget -- viewport )
- [ viewport? ] find-parent ;
-
-: viewport-dim ( viewport -- dim )
- gadget-child pref-dim viewport-gap 2 v*n v+ ;
-
-: <viewport> ( content model -- viewport )
- viewport new-gadget
- swap >>model
- t >>clipped?
- [ swap add-gadget drop ] keep ;
-
-M: viewport layout*
- dup rect-dim viewport-gap 2 v*n v-
- over gadget-child pref-dim vmax
- swap gadget-child (>>dim) ;
-
-M: viewport focusable-child*
- gadget-child ;
-
-M: viewport pref-dim* viewport-dim ;
-
-: scroller-value ( scroller -- loc )
- gadget-model range-value [ >fixnum ] map ;
-
-M: viewport model-changed
- nip
- dup relayout-1
- dup scroller-value
- vneg viewport-gap v+
- swap gadget-child set-rect-loc ;
-
-: visible-dim ( gadget -- dim )
- dup gadget-parent viewport? [
- gadget-parent rect-dim viewport-gap 2 v*n v-
- ] [
- rect-dim
- ] if ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-World gadgets are the top level of the gadget hierarchy and are displayed in native windows
+++ /dev/null
-USING: ui.gadgets ui.render ui.gestures ui.backend help.markup
-help.syntax models opengl strings ;
-IN: ui.gadgets.worlds
-
-HELP: origin
-{ $var-description "Within the dynamic extent of " { $link draw-world } ", holds the co-ordinate system origin for the gadget currently being drawn." } ;
-
-HELP: hand-world
-{ $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ;
-
-HELP: set-title
-{ $values { "string" string } { "world" world } }
-{ $description "Sets the title bar of the native window containing the world." }
-{ $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ;
-
-HELP: select-gl-context
-{ $values { "handle" "a backend-specific handle" } }
-{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
-
-HELP: flush-gl-context
-{ $values { "handle" "a backend-specific handle" } }
-{ $description "Ensures all GL rendering calls made to an OpenGL context finish rendering to the screen. This word is called automatically by the UI after drawing a " { $link world } "." } ;
-
-HELP: focus-path
-{ $values { "world" world } { "seq" "a new sequence" } }
-{ $description "If the top-level window containing the world has focus, outputs a sequence of parents of the currently focused gadget, otherwise outputs " { $link f } "." }
-{ $notes "This word is used to avoid sending " { $link gain-focus } " gestures to a gadget which requests focus on an unfocused top-level window, so that, for instance, a text editing caret does not appear in this case." } ;
-
-HELP: world
-{ $class-description "A gadget which appears at the top of the gadget hieararchy, and in turn may be displayed in a native window. Worlds have the following slots:"
- { $list
- { { $snippet "active?" } " - if set to " { $link f } ", the world will not be drawn. This slot is set to " { $link f } " if an error is thrown while drawing the world; this prevents multiple debugger windows from being shown." }
- { { $snippet "glass" } " - a glass pane in front of the primary gadget, used to implement behaviors such as popup menus which are hidden when the mouse is clicked outside the menu." }
- { { $snippet "title" } " - a string to be displayed in the title bar of the native window containing the world." }
- { { $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 "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." }
- }
-} ;
-
-HELP: <world>
-{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } }
-{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
-
-HELP: find-world
-{ $values { "gadget" gadget } { "world" "a " { $link world } " or " { $link f } } }
-{ $description "Finds the " { $link world } " containing the gadget, or outputs " { $link f } " if the gadget is not grafted." } ;
-
-HELP: draw-world
-{ $values { "world" world } }
-{ $description "Redraws a world." }
-{ $notes "This word should only be called by the UI backend. To force a gadget to redraw from user code, call " { $link relayout-1 } "." } ;
+++ /dev/null
-IN: ui.gadgets.worlds.tests
-USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
-namespaces models kernel ;
-
-! Test focus behavior
-<gadget> "g1" set
-
-: <test-world> ( gadget -- world )
- "Hi" f <world> ;
-
-[ ] [
- "g1" get <test-world> "w" set
-] unit-test
-
-[ ] [ "g1" get request-focus ] unit-test
-
-[ t ] [ "w" get gadget-focus "g1" get eq? ] unit-test
-
-<gadget> "g1" set
-<gadget> "g2" set
-"g1" get "g2" get swap add-gadget drop
-
-[ ] [
- "g2" get <test-world> "w" set
-] unit-test
-
-[ ] [ "g1" get request-focus ] unit-test
-
-[ t ] [ "w" get gadget-focus "g2" get eq? ] unit-test
-[ t ] [ "g2" get gadget-focus "g1" get eq? ] unit-test
-[ f ] [ "g1" get gadget-focus ] unit-test
-
-<gadget> "g1" set
-<gadget> "g2" set
-<gadget> "g3" set
-"g1" get "g3" get swap add-gadget drop
-"g2" get "g3" get swap add-gadget drop
-
-[ ] [
- "g3" get <test-world> "w" set
-] unit-test
-
-[ ] [ "g1" get request-focus ] unit-test
-[ ] [ "g2" get unparent ] unit-test
-[ t ] [ "g3" get gadget-focus "g1" get eq? ] unit-test
-
-[ t ] [ <gadget> dup <test-world> focusable-child eq? ] unit-test
-
-TUPLE: focusing < gadget ;
-
-: <focusing>
- focusing new-gadget ;
-
-TUPLE: focus-test < gadget ;
-
-: <focus-test>
- focus-test new-gadget
- <focusing> over swap add-gadget drop ;
-
-M: focus-test focusable-child* gadget-child ;
-
-<focus-test> "f" set
-
-[ ] [ "f" get <test-world> request-focus ] unit-test
-
-[ t ] [ "f" get gadget-focus "f" get gadget-child eq? ] unit-test
-
-[ t ] [ "f" get gadget-child focusing? ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs continuations kernel math models
-namespaces opengl sequences io combinators math.vectors
-ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-debugger math.geometry.rect ;
-IN: ui.gadgets.worlds
-
-TUPLE: world < track
-active? focused?
-glass
-title status
-fonts handle
-window-loc ;
-
-: find-world ( gadget -- world ) [ world? ] find-parent ;
-
-M: f world-status ;
-
-: show-status ( string/f gadget -- )
- find-world world-status [ set-model ] [ drop ] if* ;
-
-: hide-status ( gadget -- ) f swap show-status ;
-
-: (request-focus) ( child world ? -- )
- pick gadget-parent pick eq? [
- >r >r dup gadget-parent dup r> r>
- [ (request-focus) ] keep
- ] unless focus-child ;
-
-M: world request-focus-on ( child gadget -- )
- 2dup eq?
- [ 2drop ] [ dup world-focused? (request-focus) ] if ;
-
-: <world> ( gadget title status -- world )
- { 0 1 } world new-track
- t >>root?
- t >>active?
- H{ } clone >>fonts
- { 0 0 } >>window-loc
- swap >>status
- swap >>title
- swap 1 track-add
- dup request-focus ;
-
-M: world layout*
- dup call-next-method
- dup world-glass [
- >r dup rect-dim r> (>>dim)
- ] when* drop ;
-
-M: world focusable-child* gadget-child ;
-
-M: world children-on nip gadget-children ;
-
-: (draw-world) ( world -- )
- dup world-handle [
- [ dup init-gl ] keep draw-gadget
- ] with-gl-context ;
-
-: draw-world? ( world -- ? )
- #! We don't draw deactivated worlds, or those with 0 size.
- #! On Windows, the latter case results in GL errors.
- dup world-active?
- over world-handle
- rot rect-dim [ 0 > ] all? and and ;
-
-TUPLE: world-error error world ;
-
-C: <world-error> world-error
-
-SYMBOL: ui-error-hook
-
-: ui-error ( error -- )
- ui-error-hook get [ call ] [ print-error ] if* ;
-
-[ rethrow ] ui-error-hook set-global
-
-: draw-world ( world -- )
- dup draw-world? [
- dup world [
- [
- (draw-world)
- ] [
- over <world-error> ui-error
- f swap set-world-active?
- ] recover
- ] with-variable
- ] [
- drop
- ] if ;
-
-world H{
- { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
- { T{ key-down f { C+ } "c" } [ T{ copy-action } send-action ] }
- { T{ key-down f { C+ } "v" } [ T{ paste-action } send-action ] }
- { T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
- { T{ button-down f { C+ } 1 } [ T{ button-down f f 3 } swap resend-button-down ] }
- { T{ button-down f { A+ } 1 } [ T{ button-down f f 2 } swap resend-button-down ] }
- { T{ button-up f { C+ } 1 } [ T{ button-up f f 3 } swap resend-button-up ] }
- { T{ button-up f { A+ } 1 } [ T{ button-up f f 2 } swap resend-button-up ] }
-} set-gestures
-
-: close-global ( world global -- )
- dup get-global find-world rot eq?
- [ f swap set-global ] [ drop ] if ;
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ui.gadgets kernel ;
-
-IN: ui.gadgets.wrappers
-
-TUPLE: wrapper < gadget ;
-
-: new-wrapper ( child class -- wrapper ) new-gadget swap add-gadget ;
-
-: <wrapper> ( child -- border ) wrapper new-wrapper ;
-
-M: wrapper pref-dim* ( wrapper -- dim ) gadget-child pref-dim ;
-
-M: wrapper layout* ( wrapper -- ) [ dim>> ] [ gadget-child ] bi (>>dim) ;
-
-M: wrapper focusable-child* ( wrapper -- child/t ) gadget-child ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax hashtables
-strings kernel system ;
-IN: ui.gestures
-
-HELP: set-gestures
-{ $values { "class" "a class word" } { "hash" hashtable } }
-{ $description "Sets the gestures a gadget class responds to. The hashtable maps gestures to quotations with stack effect " { $snippet "( gadget -- )" } "." } ;
-
-HELP: handle-gesture*
-{ $values { "gadget" "the receiver of the gesture" } { "gesture" "a gesture" } { "delegate" "an object" } { "?" "a boolean" } }
-{ $contract "Handles a gesture sent to a gadget. As the delegation chain is traversed, this generic word is called with every delegate of the gadget at the top of the stack, however the front-most delegate remains fixed as the " { $snippet "gadget" } " parameter."
-$nl
-"Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's delegate." }
-{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ;
-
-HELP: handle-gesture
-{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Calls " { $link handle-gesture* } " on every delegate of " { $snippet "gadget" } ". Outputs " { $link f } " if some delegate handled the gesture, else outputs " { $link t } "." } ;
-
-{ send-gesture handle-gesture handle-gesture* set-gestures } related-words
-
-HELP: send-gesture
-{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Calls " { $link send-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
-
-HELP: user-input
-{ $values { "str" string } { "gadget" gadget } }
-{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
-
-HELP: motion
-{ $class-description "Mouse motion gesture." }
-{ $examples { $code "T{ motion }" } } ;
-
-HELP: drag
-{ $class-description "Mouse drag gesture. The " { $link drag-# } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ;
-
-HELP: button-up
-{ $class-description "Mouse button up gesture. Instances have two slots:"
- { $list
- { { $link button-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
- { { $link button-up-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
- }
-}
-{ $examples { $code "T{ button-up f f 1 }" "T{ button-up }" } } ;
-
-HELP: button-down
-{ $class-description "Mouse button down gesture. Instances have two slots:"
- { $list
- { { $link button-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
- { { $link button-down-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
- }
-}
-{ $examples { $code "T{ button-down f f 1 }" "T{ button-down }" } } ;
-
-HELP: mouse-scroll
-{ $class-description "Scroll wheel motion gesture. When this gesture is sent, the " { $link scroll-direction } " global variable is set to a direction vector." }
-{ $examples { $code "T{ mouse-scroll }" } } ;
-
-HELP: mouse-enter
-{ $class-description "Gesture sent when the mouse enters the bounds of a gadget." }
-{ $examples { $code "T{ mouse-enter }" } } ;
-
-HELP: mouse-leave
-{ $class-description "Gesture sent when the mouse leaves the bounds of a gadget." }
-{ $examples { $code "T{ mouse-leave }" } } ;
-
-HELP: gain-focus
-{ $class-description "Gesture sent when a gadget gains keyboard focus." }
-{ $examples { $code "T{ gain-focus }" } } ;
-
-HELP: lose-focus
-{ $class-description "Gesture sent when a gadget loses keyboard focus." }
-{ $examples { $code "T{ lose-focus }" } } ;
-
-HELP: cut-action
-{ $class-description "Gesture sent when the " { $emphasis "cut" } " standard window system action is invoked." }
-{ $examples { $code "T{ cut-action }" } } ;
-
-HELP: copy-action
-{ $class-description "Gesture sent when the " { $emphasis "copy" } " standard window system action is invoked." }
-{ $examples { $code "T{ copy-action }" } } ;
-
-HELP: paste-action
-{ $class-description "Gesture sent when the " { $emphasis "paste" } " standard window system action is invoked." }
-{ $examples { $code "T{ paste-action }" } } ;
-
-HELP: delete-action
-{ $class-description "Gesture sent when the " { $emphasis "delete" } " standard window system action is invoked." }
-{ $examples { $code "T{ delete-action }" } } ;
-
-HELP: select-all-action
-{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
-{ $examples { $code "T{ select-all-action }" } } ;
-
-HELP: generalize-gesture
-{ $values { "gesture" "a gesture" } { "newgesture" "a new gesture" } }
-{ $description "Turns a " { $link button-down } ", " { $link button-up } " or " { $link drag } " action naming a specific mouse button into one which can apply regardless of which mouse button was pressed." } ;
-
-HELP: C+
-{ $description "Control key modifier." } ;
-
-HELP: A+
-{ $description "Alt key modifier." } ;
-
-HELP: M+
-{ $description "Meta key modifier. This is the Command key on Mac OS X." } ;
-
-HELP: S+
-{ $description "Shift key modifier." } ;
-
-HELP: key-down
-{ $class-description "Key down gesture. Instances have two slots:"
- { $list
- { { $link key-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
- { { $link key-down-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
- }
-}
-{ $examples { $code "T{ key-down f { C+ } \"a\" }" "T{ key-down f f \"TAB\" }" } } ;
-
-HELP: key-up
-{ $class-description "Key up gesture. Instances have two slots:"
- { $list
- { { $link key-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
- { { $link key-up-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
- }
-}
-{ $examples { $code "T{ key-up f { C+ } \"a\" }" "T{ key-up f f \"TAB\" }" } } ;
-
-HELP: hand-gadget
-{ $var-description "Global variable. The gadget at the mouse location." } ;
-
-HELP: hand-loc
-{ $var-description "Global variable. The mouse location relative to the top-left corner of the " { $link hand-world } "." } ;
-
-{ hand-loc hand-rel } related-words
-
-HELP: hand-clicked
-{ $var-description "Global variable. The gadget at the location of the most recent click." } ;
-
-HELP: hand-click-loc
-{ $var-description "Global variable. The mouse location at the time of the most recent click relative to the top-left corner of the " { $link hand-world } "." } ;
-
-{ hand-clicked hand-click-loc } related-words
-
-HELP: hand-click#
-{ $var-description "Global variable. The number of times the mouse was clicked in short succession. This counter is reset when " { $link double-click-timeout } " expires." } ;
-
-HELP: hand-last-button
-{ $var-description "Global variable. The mouse button most recently pressed." } ;
-
-HELP: hand-last-time
-{ $var-description "Global variable. The timestamp of the most recent mouse button click. This timestamp has the same format as the output value of " { $link millis } "." } ;
-
-HELP: hand-buttons
-{ $var-description "Global variable. A vector of mouse buttons currently held down." } ;
-
-HELP: scroll-direction
-{ $var-description "Global variable. If the most recent gesture was a " { $link mouse-scroll } ", this holds a pair of integers indicating the direction of the scrolling as a two-dimensional vector." } ;
-
-HELP: double-click-timeout
-{ $var-description "Global variable. The maximum delay between two button presses which will still increment " { $link hand-click# } "." } ;
-
-HELP: button-gesture
-{ $values { "gesture" "a gesture" } }
-{ $description "Sends a gesture to the most recently clicked gadget, and if the gadget does not respond to the gesture, removes specific button number information from the gesture and sends it again." } ;
-
-HELP: fire-motion
-{ $description "Sends a " { $link motion } " or " { $link drag } " gesture to the gadget under the mouse, depending on whether a mouse button is being held down or not." } ;
-
-HELP: forget-rollover
-{ $description "Sends " { $link mouse-leave } " gestures to all gadgets containing the gadget under the mouse, and resets the " { $link hand-gadget } " variable." } ;
-
-HELP: request-focus
-{ $values { "gadget" gadget } }
-{ $description "Gives keyboard focus to the " { $link focusable-child } " of the gadget. This may result in " { $link lose-focus } " and " { $link gain-focus } " gestures being sent." } ;
-
-HELP: drag-loc
-{ $values { "loc" "a pair of integers" } }
-{ $description "Outputs the distance travelled by the mouse since the most recent press. Only meaningful inside a " { $link drag } " gesture handler." } ;
-
-HELP: hand-rel
-{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
-{ $description "Outputs the location of the mouse relative to the top-left corner of the gadget. Only meaningful inside a " { $link button-down } ", " { $link button-up } ", " { $link motion } " or " { $link drag } " gesture handler, where the gadget is contained in the same world as the gadget receiving the gesture." } ;
-
-HELP: hand-click-rel
-{ $values { "gadget" gadget } { "loc" "a pair of integers" } }
-{ $description "Outputs the location of the last mouse relative to the top-left corner of the gadget. Only meaningful inside a " { $link button-down } ", " { $link button-up } ", " { $link motion } " or " { $link drag } " gesture handler, where the gadget is contained in the same world as the gadget receiving the gesture." } ;
-
-HELP: under-hand
-{ $values { "seq" "a new sequence" } }
-{ $description "Outputs a sequence where the first element is the " { $link hand-world } " and the last is the " { $link hand-gadget } ", with all parents in between." } ;
-
-HELP: gesture>string
-{ $values { "gesture" "a gesture" } { "string/f" "a " { $link string } " or " { $link f } } }
-{ $contract "Creates a human-readable string from a gesture object, returning " { $link f } " if the gesture does not have a human-readable form." }
-{ $examples
- { $example "USING: io ui.gestures ;" "T{ key-down f { C+ } \"x\" } gesture>string print" "C+x" }
-} ;
-
-ARTICLE: "ui-gestures" "UI gestures"
-"User actions such as keyboard input and mouse button clicks deliver " { $emphasis "gestures" } " to gadgets. If the direct receiver of the gesture does not handle it, the gesture is passed on to the receiver's parent, and this way it travels up the gadget hierarchy. Gestures which are not handled at some point are ignored."
-$nl
-"There are two ways to define gesture handling logic. The simplest way is to associate a fixed set of gestures with a class:"
-{ $subsection set-gestures }
-"Another way is to define a generic word on a class which handles all gestures sent to gadgets of that class:"
-{ $subsection handle-gesture* }
-"Sometimes a gesture needs to be presented to the user:"
-{ $subsection gesture>string }
-"Keyboard input:"
-{ $subsection "ui-focus" }
-{ $subsection "keyboard-gestures" }
-{ $subsection "action-gestures" }
-{ $subsection "ui-user-input" }
-"Mouse input:"
-{ $subsection "mouse-gestures" }
-"Abstractions built on top of gestures:"
-{ $subsection "ui-commands" }
-{ $subsection "ui-operations" } ;
-
-ARTICLE: "ui-focus" "Keyboard focus"
-"The gadget with keyboard focus is the current receiver of keyboard gestures and user input. Gadgets that wish to receive keyboard input should request focus when clicked:"
-{ $subsection request-focus }
-"The following example demonstrates defining a handler for a mouse click gesture which requests focus:"
-{ $code
- "my-gadget H{"
- " { T{ button-down } [ request-focus ] }"
- "} set-gestures"
-}
-"To nominate a single child as the default focusable child, implement a method on a generic word:"
-{ $subsection focusable-child* }
-"Gestures are sent to a gadget when it gains or loses focus; this can be used to change the gadget's appearance, for example by displaying a border:"
-{ $subsection gain-focus }
-{ $subsection lose-focus } ;
-
-ARTICLE: "keyboard-gestures" "Keyboard gestures"
-"There are two types of keyboard gestures:"
-{ $subsection key-down }
-{ $subsection key-up }
-"Each keyboard gesture has a set of modifiers and a key symbol. The set modifiers is denoted by an array which must either be " { $link f } ", or an order-preserving subsequence of the following:"
-{ $code "{ S+ C+ A+ M+ }" }
-{ $subsection S+ }
-{ $subsection C+ }
-{ $subsection A+ }
-{ $subsection M+ }
-"A key symbol is either a single-character string denoting literal input, or one of the following strings:"
-{ $list
- { $snippet "CLEAR" }
- { $snippet "RET" }
- { $snippet "ENTER" }
- { $snippet "ESC" }
- { $snippet "TAB" }
- { $snippet "BACKSPACE" }
- { $snippet "HOME" }
- { $snippet "DELETE" }
- { $snippet "END" }
- { $snippet "F1" }
- { $snippet "F2" }
- { $snippet "F3" }
- { $snippet "F4" }
- { $snippet "F5" }
- { $snippet "F6" }
- { $snippet "F7" }
- { $snippet "F8" }
- { $snippet "LEFT" }
- { $snippet "RIGHT" }
- { $snippet "DOWN" }
- { $snippet "UP" }
- { $snippet "PAGE_UP" }
- { $snippet "PAGE_DOWN" }
-}
-"The " { $link S+ } " modifier is only ever used with the above action keys; alphanumeric input input with the shift key is delivered without the " { $link S+ } " modifier set, instead the input itself is upper case. For example, the gesture corresponding to " { $snippet "s" } " with the Control and Shift keys pressed is presented as "
-{ $code "T{ key-down f { C+ } \"S\" }" }
-"The " { $snippet "RET" } ", " { $snippet "TAB" } " and " { $snippet "SPACE" } " keys are never delivered in their literal form (" { $snippet "\"\\n\"" } ", " { $snippet "\"\\t\"" } " or " { $snippet "\" \"" } ")." ;
-
-ARTICLE: "ui-user-input" "Free-form keyboard input"
-"Whereas keyboard gestures are intended to be used for keyboard shortcuts, certain gadgets such as text fields need to accept free-form keyboard input. This can be done by implementing a generic word:"
-{ $subsection user-input* } ;
-
-ARTICLE: "mouse-gestures" "Mouse gestures"
-"There are two types of mouse gestures indicating button clicks:"
-{ $subsection button-down }
-{ $subsection button-up }
-"When a mouse button is pressed or released, two gestures are sent. The first gesture indicates the specific button number, and if this gesture is not handled, the second has a button number set to " { $link f } ":"
-{ $code "T{ button-down f 1 }" "T{ button-down f f }" }
-"Because tuple literals fill unspecified slots with " { $link f } ", the last gesture can be written as " { $snippet "T{ button-down }" } "."
-$nl
-"Gestures to indicate mouse motion, depending on whenever a button is held down or not:"
-{ $subsection motion }
-{ $subsection drag }
-"Gestures to indicate that the mouse has crossed gadget boundaries:"
-{ $subsection mouse-enter }
-{ $subsection mouse-leave }
-"A number of global variables are set after a mouse gesture is sent. These variables can be read to obtain additional information about the gesture."
-{ $subsection hand-gadget }
-{ $subsection hand-world }
-{ $subsection hand-loc }
-{ $subsection hand-buttons }
-{ $subsection hand-clicked }
-{ $subsection hand-click-loc }
-{ $subsection hand-click# }
-"There are some utility words for working with click locations:"
-{ $subsection hand-rel }
-{ $subsection hand-click-rel }
-{ $subsection drag-loc }
-"Mouse scroll wheel gesture:"
-{ $subsection mouse-scroll }
-"Global variable set when a mouse scroll wheel gesture is sent:"
-{ $subsection scroll-direction } ;
-
-ARTICLE: "action-gestures" "Action gestures"
-"Action gestures exist to keep keyboard shortcuts for common clipboard operations consistent."
-{ $subsection cut-action }
-{ $subsection copy-action }
-{ $subsection paste-action }
-{ $subsection delete-action }
-{ $subsection select-all-action }
-"The following keyboard gestures, if not handled directly, send action gestures:"
-{ $table
- { { $strong "Keyboard gesture" } { $strong "Action gesture" } }
- { { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "T{ cut-action }" } }
- { { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "T{ copy-action }" } }
- { { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "T{ paste-action }" } }
- { { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "T{ select-all }" } }
-}
-"Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ;
-
-ABOUT: "ui-gestures"
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs kernel math models namespaces
-sequences words strings system hashtables math.parser
-math.vectors classes.tuple classes ui.gadgets boxes
-calendar alarms symbols combinators sets columns ;
-IN: ui.gestures
-
-: set-gestures ( class hash -- ) "gestures" set-word-prop ;
-
-GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
-
-: default-gesture-handler ( gadget gesture delegate -- ? )
- class superclasses [ "gestures" word-prop ] map assoc-stack dup
- [ call f ] [ 2drop t ] if ;
-
-M: object handle-gesture* default-gesture-handler ;
-
-: handle-gesture ( gesture gadget -- ? )
- tuck delegates [ >r 2dup r> handle-gesture* ] all? 2nip ;
-
-: send-gesture ( gesture gadget -- ? )
- [ dupd handle-gesture ] each-parent nip ;
-
-: user-input ( str gadget -- )
- over empty?
- [ [ dupd user-input* ] each-parent ] unless
- 2drop ;
-
-! Gesture objects
-TUPLE: motion ; C: <motion> motion
-TUPLE: drag # ; C: <drag> drag
-TUPLE: button-up mods # ; C: <button-up> button-up
-TUPLE: button-down mods # ; C: <button-down> button-down
-TUPLE: mouse-scroll ; C: <mouse-scroll> mouse-scroll
-TUPLE: mouse-enter ; C: <mouse-enter> mouse-enter
-TUPLE: mouse-leave ; C: <mouse-leave> mouse-leave
-TUPLE: lose-focus ; C: <lose-focus> lose-focus
-TUPLE: gain-focus ; C: <gain-focus> gain-focus
-
-! Higher-level actions
-TUPLE: cut-action ; C: <cut-action> cut-action
-TUPLE: copy-action ; C: <copy-action> copy-action
-TUPLE: paste-action ; C: <paste-action> paste-action
-TUPLE: delete-action ; C: <delete-action> delete-action
-TUPLE: select-all-action ; C: <select-all-action> select-all-action
-
-TUPLE: left-action ; C: <left-action> left-action
-TUPLE: right-action ; C: <right-action> right-action
-TUPLE: up-action ; C: <up-action> up-action
-TUPLE: down-action ; C: <down-action> down-action
-
-TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
-TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
-
-: generalize-gesture ( gesture -- newgesture )
- clone f >># ;
-
-! Modifiers
-SYMBOLS: C+ A+ M+ S+ ;
-
-TUPLE: key-down mods sym ;
-
-: <key-gesture> ( mods sym action? class -- mods' sym' )
- >r [ S+ rot remove swap ] unless r> boa ; inline
-
-: <key-down> ( mods sym action? -- key-down )
- key-down <key-gesture> ;
-
-TUPLE: key-up mods sym ;
-
-: <key-up> ( mods sym action? -- key-up )
- key-up <key-gesture> ;
-
-! Hand state
-
-! Note that these are only really useful inside an event
-! handler, and that the locations hand-loc and hand-click-loc
-! are in the co-ordinate system of the world which contains
-! the gadget in question.
-SYMBOL: hand-gadget
-SYMBOL: hand-world
-SYMBOL: hand-loc
-{ 0 0 } hand-loc set-global
-
-SYMBOL: hand-clicked
-SYMBOL: hand-click-loc
-SYMBOL: hand-click#
-SYMBOL: hand-last-button
-SYMBOL: hand-last-time
-0 hand-last-button set-global
-0 hand-last-time set-global
-
-SYMBOL: hand-buttons
-V{ } clone hand-buttons set-global
-
-SYMBOL: scroll-direction
-{ 0 0 } scroll-direction set-global
-
-SYMBOL: double-click-timeout
-300 double-click-timeout set-global
-
-: hand-moved? ( -- ? )
- hand-loc get hand-click-loc get = not ;
-
-: button-gesture ( gesture -- )
- hand-clicked get-global 2dup send-gesture [
- >r generalize-gesture r> send-gesture drop
- ] [
- 2drop
- ] if ;
-
-: drag-gesture ( -- )
- hand-buttons get-global
- dup empty? [ drop ] [ first <drag> button-gesture ] if ;
-
-SYMBOL: drag-timer
-
-<box> drag-timer set-global
-
-: start-drag-timer ( -- )
- hand-buttons get-global empty? [
- [ drag-gesture ]
- 300 milliseconds hence
- 100 milliseconds
- add-alarm drag-timer get-global >box
- ] when ;
-
-: stop-drag-timer ( -- )
- hand-buttons get-global empty? [
- drag-timer get-global ?box
- [ cancel-alarm ] [ drop ] if
- ] when ;
-
-: fire-motion ( -- )
- hand-buttons get-global empty? [
- T{ motion } hand-gadget get-global send-gesture drop
- ] [
- drag-gesture
- ] if ;
-
-: each-gesture ( gesture seq -- )
- [ handle-gesture drop ] with each ;
-
-: hand-gestures ( new old -- )
- drop-prefix <reversed>
- T{ mouse-leave } swap each-gesture
- T{ mouse-enter } swap each-gesture ;
-
-: forget-rollover ( -- )
- f hand-world set-global
- hand-gadget get-global >r
- f hand-gadget set-global
- f r> parents hand-gestures ;
-
-: send-lose-focus ( gadget -- )
- T{ lose-focus } swap handle-gesture drop ;
-
-: send-gain-focus ( gadget -- )
- T{ gain-focus } swap handle-gesture drop ;
-
-: focus-child ( child gadget ? -- )
- [
- dup gadget-focus [
- dup send-lose-focus
- f swap t focus-child
- ] when*
- dupd set-gadget-focus [
- send-gain-focus
- ] when*
- ] [
- set-gadget-focus
- ] if ;
-
-: modifier ( mod modifiers -- seq )
- [ second swap bitand 0 > ] with filter
- 0 <column> prune dup empty? [ drop f ] [ >array ] if ;
-
-: drag-loc ( -- loc )
- hand-loc get-global hand-click-loc get-global v- ;
-
-: hand-rel ( gadget -- loc )
- hand-loc get-global swap screen-loc v- ;
-
-: hand-click-rel ( gadget -- loc )
- hand-click-loc get-global swap screen-loc v- ;
-
-: multi-click-timeout? ( -- ? )
- millis hand-last-time get - double-click-timeout get <= ;
-
-: multi-click-button? ( button -- button ? )
- dup hand-last-button get = ;
-
-: multi-click-position? ( -- ? )
- hand-loc get hand-click-loc get v- norm-sq 100 <= ;
-
-: multi-click? ( button -- ? )
- {
- { [ multi-click-timeout? not ] [ f ] }
- { [ multi-click-button? not ] [ f ] }
- { [ multi-click-position? not ] [ f ] }
- { [ multi-click-position? not ] [ f ] }
- [ t ]
- } cond nip ;
-
-: update-click# ( button -- )
- global [
- dup multi-click? [
- hand-click# inc
- ] [
- 1 hand-click# set
- ] if
- hand-last-button set
- millis hand-last-time set
- ] bind ;
-
-: update-clicked ( -- )
- hand-gadget get-global hand-clicked set-global
- hand-loc get-global hand-click-loc set-global ;
-
-: under-hand ( -- seq )
- hand-gadget get-global parents <reversed> ;
-
-: move-hand ( loc world -- )
- dup hand-world set-global
- under-hand >r over hand-loc set-global
- pick-up hand-gadget set-global
- under-hand r> hand-gestures ;
-
-: send-button-down ( gesture loc world -- )
- move-hand
- start-drag-timer
- dup button-down-#
- dup update-click# hand-buttons get-global push
- update-clicked
- button-gesture ;
-
-: send-button-up ( gesture loc world -- )
- move-hand
- dup button-up-# hand-buttons get-global delete
- stop-drag-timer
- button-gesture ;
-
-: send-wheel ( direction loc world -- )
- move-hand
- scroll-direction set-global
- T{ mouse-scroll } hand-gadget get-global send-gesture
- drop ;
-
-: world-focus ( world -- gadget )
- dup gadget-focus [ world-focus ] [ ] ?if ;
-
-: send-action ( world gesture -- )
- swap world-focus send-gesture drop ;
-
-: resend-button-down ( gesture world -- )
- hand-loc get-global swap send-button-down ;
-
-: resend-button-up ( gesture world -- )
- hand-loc get-global swap send-button-up ;
-
-GENERIC: gesture>string ( gesture -- string/f )
-
-: modifiers>string ( modifiers -- string )
- [ name>> ] map concat >string ;
-
-M: key-down gesture>string
- dup key-down-mods modifiers>string
- swap key-down-sym append ;
-
-M: button-up gesture>string
- [
- dup button-up-mods modifiers>string %
- "Click Button" %
- button-up-# [ " " % # ] when*
- ] "" make ;
-
-M: button-down gesture>string
- [
- dup button-down-mods modifiers>string %
- "Press Button" %
- button-down-# [ " " % # ] when*
- ] "" make ;
-
-M: left-action gesture>string drop "Swipe left" ;
-
-M: right-action gesture>string drop "Swipe right" ;
-
-M: up-action gesture>string drop "Swipe up" ;
-
-M: down-action gesture>string drop "Swipe down" ;
-
-M: zoom-in-action gesture>string drop "Zoom in" ;
-
-M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
-
-M: object gesture>string drop f ;
+++ /dev/null
-Translating window system events to gestures, and delivering gestures to gadgets
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.commands help.markup help.syntax ui.gadgets words
-kernel hashtables strings classes quotations sequences
-ui.gestures ;
-IN: ui.operations
-
-: $operations ( element -- )
- >quotation call
- f f operations>commands
- command-map. ;
-
-: $operation ( element -- )
- first +keyboard+ word-prop gesture>string $snippet ;
-
-HELP: +keyboard+
-{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". The value is a gesture." } ;
-
-HELP: +primary+
-{ $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 a presentation matching the operation's predicate is clicked with the mouse." } ;
-
-HELP: operation
-{ $description "An abstraction for an operation which may be performed on a presentation."
-$nl
-"Operations have the following slots:"
-{ $list
- { { $link operation-predicate } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
- { { $link operation-command } " - a " { $link word } }
- { { $link operation-translator } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
- { { $link operation-hook } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
- { { $link operation-listener? } " - a boolean" }
-} } ;
-
-HELP: operation-gesture
-{ $values { "operation" operation } { "gesture" "a gesture or " { $link f } } }
-{ $description "Outputs the keyboard gesture associated with the operation." } ;
-
-HELP: operations
-{ $var-description "Global variable holding a vector of " { $link operation } " instances. New operations can be added with " { $link define-operation } "." } ;
-
-HELP: object-operations
-{ $values { "obj" object } { "operations" "a sequence of " { $link operation } " instances" } }
-{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $link operation-predicate } " quotation in turn." } ;
-
-HELP: primary-operation
-{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
-{ $description "Outputs the operation which should be invoked when a presentation of " { $snippet "obj" } " is clicked." } ;
-
-HELP: secondary-operation
-{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }
-{ $description "Outputs the operation which should be invoked when a " { $snippet "RET" } " is pressed while a presentation of " { $snippet "obj" } " is selected in a list." } ;
-
-HELP: define-operation
-{ $values { "pred" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "command" word } { "flags" hashtable } }
-{ $description "Defines an operation on objects matching the predicate. The hashtable can contain the following keys:"
- { $list
- { { $link +listener+ } " - if set to a true value, the operation will run in the listener" }
- { { $link +description+ } " - can be set to a string description of the operation" }
- { { $link +primary+ } " - if set to a true value, the operation will be output by " { $link primary-operation } " when applied to an object satisfying the predicate" }
- { { $link +secondary+ } " - if set to a true value, the operation will be output by " { $link secondary-operation } " when applied to an object satisfying the predicate" }
- { { $link +keyboard+ } " - can be set to a keyboard gesture; the guesture will be used by " { $link define-operation-map } }
- }
-} ;
-
-HELP: define-operation-map
-{ $values { "class" "a class word" } { "group" string } { "blurb" "a " { $link string } " or " { $link f } } { "object" object } { "hook" "a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { "translator" "a quotation with stack effect " { $snippet "( 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." } ;
-
-HELP: $operations
-{ $values { "element" "a sequence" } }
-{ $description "Converts the element to a quotation and calls it; the resulting quotation must have stack effect " { $snippet "( -- obj )" } ". Prints a list of operations applicable to the object, together with keyboard shortcuts." } ;
-
-HELP: $operation
-{ $values { "element" "a sequence containing a single word" } }
-{ $description "Prints the keyboard shortcut associated with the word, which must have been previously defined as an operation by a call to " { $link define-operation } "." } ;
-
-ARTICLE: "ui-operations" "Operations"
-"Operations are commands performed on presentations."
-{ $subsection operation }
-{ $subsection define-operation }
-{ $subsection primary-operation }
-{ $subsection secondary-operation }
-{ $subsection define-operation-map }
-"When documenting gadgets, operation documentation can be automatically generated:"
-{ $subsection $operations }
-{ $subsection $operation } ;
-
-ABOUT: "ui-operations"
+++ /dev/null
-IN: ui.operations.tests
-USING: ui.operations ui.commands prettyprint kernel namespaces
-tools.test ui.gadgets ui.gadgets.editors parser io
-io.streams.string math help help.markup ;
-
-: my-pprint pprint ;
-
-[ drop t ] \ my-pprint [ ] [ ] f operation boa "op" set
-
-[ [ 3 my-pprint ] ] [
- 3 "op" get operation-command command-quot
-] unit-test
-
-[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
-
-[ drop t ] \ my-pprint [ ] [ editor-string ] f operation boa
-"op" set
-
-[ "\"4\"" ] [
- [
- "4" <editor> [ set-editor-string ] keep
- "op" get invoke-command
- ] with-string-writer
-] unit-test
-
-[ ] [
- [ { $operations \ + } print-element ] with-string-writer drop
-] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 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
-hashtables help.markup quotations assocs ;
-IN: ui.operations
-
-SYMBOL: +keyboard+
-SYMBOL: +primary+
-SYMBOL: +secondary+
-
-TUPLE: operation predicate command translator hook listener? ;
-
-: <operation> ( predicate command -- operation )
- operation new
- [ ] >>hook
- [ ] >>translator
- swap >>command
- swap >>predicate ;
-
-PREDICATE: listener-operation < operation
- dup operation-command listener-command?
- swap operation-listener? or ;
-
-M: operation command-name
- operation-command command-name ;
-
-M: operation command-description
- operation-command command-description ;
-
-M: operation command-word operation-command command-word ;
-
-: operation-gesture ( operation -- gesture )
- operation-command +keyboard+ word-prop ;
-
-SYMBOL: operations
-
-: object-operations ( obj -- operations )
- operations get [ operation-predicate call ] with filter ;
-
-: find-operation ( obj quot -- command )
- >r object-operations r> find-last nip ; inline
-
-: primary-operation ( obj -- operation )
- [ operation-command +primary+ word-prop ] find-operation ;
-
-: secondary-operation ( obj -- operation )
- dup
- [ operation-command +secondary+ word-prop ] find-operation
- [ ] [ primary-operation ] ?if ;
-
-: default-flags ( -- assoc )
- H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
-
-: define-operation ( pred command flags -- )
- default-flags swap assoc-union
- dupd define-command <operation>
- operations get push ;
-
-: modify-operation ( hook translator operation -- operation )
- clone
- tuck set-operation-translator
- tuck set-operation-hook
- t over set-operation-listener? ;
-
-: modify-operations ( operations hook translator -- operations )
- rot [ >r 2dup r> modify-operation ] map 2nip ;
-
-: operations>commands ( object hook translator -- pairs )
- >r >r object-operations r> r> modify-operations
- [ [ operation-gesture ] keep ] { } map>assoc ;
-
-: define-operation-map ( class group blurb object hook translator -- )
- operations>commands define-command-map ;
-
-: operation-quot ( target command -- quot )
- [
- swap literalize ,
- dup operation-translator %
- operation-command ,
- ] [ ] make ;
-
-M: operation invoke-command ( target command -- )
- [ operation-hook call ] keep operation-quot call ;
+++ /dev/null
-Operations are commands which may be performed on a presentation's underlying object
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets ui.gestures help.markup help.syntax
-kernel classes strings opengl.gl models math.geometry.rect ;
-IN: ui.render
-
-HELP: gadget
-{ $class-description "An object which displays itself on the screen and acts on user input gestures. Gadgets have the following slots:"
- { $list
- { { $snippet "pref-dim" } " - a cached value for " { $link pref-dim } "; do not read or write this slot directly." }
- { { $snippet "parent" } " - the gadget containing this one, or " { $link f } " if this gadget is not part of the visible gadget hierarchy." }
- { { $snippet "children" } " - a vector of child gadgets. Do not modify this vector directly, instead use " { $link add-gadget } ", " { $link add-gadgets } ", " { $link unparent } " or " { $link clear-gadget } "." }
- { { $snippet "orientation" } " - an orientation specifier. This slot is used by layout gadgets." }
- { { $snippet "layout-state" } " - stores the layout state of the gadget. Do not read or write this slot directly, instead call " { $link relayout } " and " { $link relayout-1 } " if the gadget needs to be re-laid out." }
- { { $snippet "visible?" } " - a boolean indicating if the gadget should display and receive user input." }
- { { $snippet "root?" } " - if set to " { $link t } ", layout changes in this gadget will not propagate to the gadget's parent." }
- { { $snippet "clipped?" } " - a boolean indicating if clipping will be enabled when drawing this gadget's children." }
- { { $snippet "interior" } " - an object whose class implements the " { $link draw-interior } " generic word." }
- { { $snippet "boundary" } " - an object whose class implements the " { $link draw-boundary } " generic word." }
- { { $snippet "model" } " - a " { $link model } " or " { $link f } "; see " { $link "ui-control-impl" } }
- }
-"Gadgets subclass the " { $link rect } " class, and thus all instances have " { $snippet "loc" } " and " { $snippet "dim" } " instances holding their location and dimensions." }
-{ $notes
-"Other classes may inherit from " { $link gadget } " in order to re-implement generic words such as " { $link draw-gadget* } " and " { $link user-input* } ", or to define gestures with " { $link set-gestures } "." } ;
-
-HELP: clip
-{ $var-description "The current clipping rectangle." } ;
-
-HELP: draw-gadget*
-{ $values { "gadget" gadget } }
-{ $contract "Draws the gadget by making OpenGL calls. The top-left corner of the gadget should be drawn at the location stored in the " { $link origin } " variable." }
-{ $notes "This word should not be called directly. To force a gadget to redraw, call " { $link relayout-1 } "." } ;
-
-HELP: draw-interior
-{ $values { "interior" object } { "gadget" gadget } }
-{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $link gadget-interior } " slot may be set to objects implementing this generic word." } ;
-
-HELP: draw-boundary
-{ $values { "boundary" object } { "gadget" gadget } }
-{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $link gadget-boundary } " slot may be set to objects implementing this generic word." } ;
-
-HELP: solid
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ;
-
-HELP: gradient
-{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $link gadget-orientation } " slot of the gadget." } ;
-
-HELP: polygon
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
- { $list
- { { $link polygon-color } " - a color specifier" }
- { { $link polygon-points } " - a sequence of points" }
- }
-} ;
-
-HELP: <polygon>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } }
-{ $description "Creates a new instance of " { $link polygon } "." } ;
-
-HELP: <polygon-gadget>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "gadget" "a new " { $link gadget } } }
-{ $description "Creates a gadget which is drawn as a solid filled polygon. The gadget's size is the minimum bounding box containing all the points of the polygon." } ;
-
-HELP: open-font
-{ $values { "font" "a font specifier" } { "open-font" object } }
-{ $description "Loads a font if it has not already been loaded, otherwise outputs the existing font." }
-{ $errors "Throws an error if the font does not exist." } ;
-
-HELP: string-width
-{ $values { "open-font" "a value output by " { $link open-font } } { "string" string } { "w" "a positive integer" } }
-{ $description "Outputs the width of a string." } ;
-
-HELP: text-dim
-{ $values { "open-font" "a value output by " { $link open-font } } { "text" "a string or an array of strings" } { "dim" "a pair of integers" } }
-{ $description "Outputs the dimensions of a piece of text, which is either a single-line string or an array of lines." } ;
-
-HELP: draw-string
-{ $values { "font" "a font specifier" } { "string" string } { "loc" "a pair of integers" } }
-{ $description "Draws a line of text." } ;
-
-HELP: draw-text
-{ $values { "font" "a font specifier" } { "text" "a string or an array of strings" } { "loc" "a pair of integers" } }
-{ $description "Draws text. Text is either a single-line string or an array of lines." } ;
-
-ARTICLE: "gadgets-polygons" "Polygon gadgets"
-"A polygon gadget renders a simple shaded polygon."
-{ $subsection <polygon-gadget> }
-"Some pre-made polygons:"
-{ $subsection arrow-up }
-{ $subsection arrow-right }
-{ $subsection arrow-down }
-{ $subsection arrow-left }
-{ $subsection close-box }
-"Polygon gadgets are rendered by the " { $link polygon } " pen protocol implementation." ;
-
-ARTICLE: "ui-paint" "Customizing gadget appearance"
-"The UI carries out the following steps when drawing a gadget:"
-{ $list
- { "The " { $link draw-interior } " generic word is called on the value of the " { $link gadget-interior } " slot." }
- { "The " { $link draw-gadget* } " generic word is called on the gadget." }
- { "The gadget's visible children are drawn, determined by calling " { $link visible-children } " on the gadget." }
- { "The " { $link draw-boundary } " generic word is called on the value of the " { $link gadget-boundary } " slot." }
-}
-"Now, each one of these steps will be covered in detail."
-{ $subsection "ui-pen-protocol" }
-{ $subsection "ui-paint-custom" } ;
-
-ARTICLE: "ui-pen-protocol" "UI pen protocol"
-"The " { $link gadget-interior } " and " { $link gadget-boundary } " slots of a gadget facilitate easy factoring and sharing of drawing logic. Objects stored in these slots must implement the pen protocol:"
-{ $subsection draw-interior }
-{ $subsection draw-boundary }
-"The default value of these slots is the " { $link f } " singleton, which implements the above protocol by doing nothing."
-$nl
-"Some other pre-defined implementations:"
-{ $subsection solid }
-{ $subsection gradient }
-{ $subsection polygon }
-"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
-
-ARTICLE: "text-rendering" "Rendering text"
-"Unlike OpenGL, Factor's FreeType binding only includes the bare essentials, and there is rarely any need to directly call words in the " { $vocab-link "freetype" } " vocabulary directly. Instead, the UI provides high-level wrappers."
-$nl
-"Font objects are never constructed directly, and instead are obtained by calling a word:"
-{ $subsection open-font }
-"Measuring text:"
-{ $subsection text-dim }
-{ $subsection text-height }
-{ $subsection text-width }
-"Rendering text:"
-{ $subsection draw-string }
-{ $subsection draw-text } ;
-
-ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
-"The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
-{ $subsection draw-gadget* }
-"Custom drawing code has access to the full OpenGL API in the " { $vocab-link "opengl" } " vocabulary."
-$nl
-"The UI uses a co-ordinate system where the y axis is oriented down. The OpenGL " { $link GL_MODELVIEW } " matrix is not saved or restored when rendering a gadget. Instead, the origin of the gadget relative to the OpenGL context is stored in a variable:"
-{ $subsection origin }
-"Custom drawing implementations can translate co-ordinates manually, or save and restore the " { $link GL_MODELVIEW } " matrix."
-$nl
-"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
-$nl
-"Gadgets must not draw outside of their bounding box, however clipping is not enforced by default, for performance reasons. This can be changed by setting the " { $link gadget-clipped? } " slot to " { $link t } " in the gadget's constructor."
-$nl
-"Saving the " { $link GL_MODELVIEW } " matrix and enabling/disabling flags can be done in a clean way using the combinators documented in the following section."
-{ $subsection "gl-utilities" }
-{ $subsection "text-rendering" } ;
-
-ABOUT: "ui-paint-custom"
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays hashtables io kernel math namespaces opengl
-opengl.gl opengl.glu sequences strings io.styles vectors
-combinators math.vectors ui.gadgets colors
-math.order math.geometry.rect ;
-IN: ui.render
-
-SYMBOL: clip
-
-SYMBOL: viewport-translation
-
-: flip-rect ( rect -- loc dim )
- rect-bounds [
- >r { 1 -1 } v* r> { 0 -1 } v* v+
- viewport-translation get v+
- ] keep ;
-
-: do-clip ( -- ) clip get flip-rect gl-set-clip ;
-
-: init-clip ( clip-rect rect -- )
- GL_SCISSOR_TEST glEnable
- [ rect-intersect ] keep
- rect-dim dup { 0 1 } v* viewport-translation set
- { 0 0 } over gl-viewport
- 0 swap first2 0 gluOrtho2D
- clip set
- do-clip ;
-
-: init-gl ( clip-rect rect -- )
- GL_SMOOTH glShadeModel
- GL_BLEND glEnable
- GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
- init-matrices
- init-clip
- ! white gl-clear is broken w.r.t window resizing
- ! Linux/PPC Radeon 9200
- white set-color
- clip get rect-extent gl-fill-rect ;
-
-GENERIC: draw-gadget* ( gadget -- )
-
-M: gadget draw-gadget* drop ;
-
-GENERIC: draw-interior ( gadget interior -- )
-
-GENERIC: draw-boundary ( gadget boundary -- )
-
-SYMBOL: origin
-
-{ 0 0 } origin set-global
-
-: visible-children ( gadget -- seq )
- clip get origin get vneg offset-rect swap children-on ;
-
-: translate ( rect/point -- ) rect-loc origin [ v+ ] change ;
-
-DEFER: draw-gadget
-
-: (draw-gadget) ( gadget -- )
- [
- dup translate
- dup dup gadget-interior draw-interior
- dup draw-gadget*
- dup visible-children [ draw-gadget ] each
- dup gadget-boundary draw-boundary
- ] with-scope ;
-
-: >absolute ( rect -- rect )
- origin get offset-rect ;
-
-: change-clip ( gadget -- )
- >absolute clip [ rect-intersect ] change ;
-
-: with-clipping ( gadget quot -- )
- clip get >r
- over change-clip do-clip call
- r> clip set do-clip ; inline
-
-: draw-gadget ( gadget -- )
- {
- { [ dup gadget-visible? not ] [ drop ] }
- { [ dup gadget-clipped? not ] [ (draw-gadget) ] }
- [ [ (draw-gadget) ] with-clipping ]
- } cond ;
-
-! Pen paint properties
-M: f draw-interior 2drop ;
-M: f draw-boundary 2drop ;
-
-! Solid fill/border
-TUPLE: solid color ;
-
-C: <solid> solid
-
-! Solid pen
-: (solid) ( gadget paint -- loc dim )
- solid-color set-color rect-dim >r origin get dup r> v+ ;
-
-M: solid draw-interior (solid) gl-fill-rect ;
-
-M: solid draw-boundary (solid) gl-rect ;
-
-! Gradient pen
-TUPLE: gradient colors ;
-
-C: <gradient> gradient
-
-M: gradient draw-interior
- origin get [
- over gadget-orientation
- swap gradient-colors
- rot rect-dim
- gl-gradient
- ] with-translation ;
-
-! Polygon pen
-TUPLE: polygon color points ;
-
-C: <polygon> polygon
-
-: draw-polygon ( polygon quot -- )
- origin get [
- >r dup polygon-color set-color polygon-points r> call
- ] with-translation ; inline
-
-M: polygon draw-boundary
- [ gl-poly ] draw-polygon drop ;
-
-M: polygon draw-interior
- [ gl-fill-poly ] draw-polygon drop ;
-
-: arrow-up { { 3 0 } { 6 6 } { 0 6 } } ;
-: arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;
-: arrow-down { { 0 0 } { 6 0 } { 3 6 } } ;
-: arrow-left { { 0 3 } { 6 0 } { 6 6 } } ;
-: close-box { { 0 0 } { 6 0 } { 6 6 } { 0 6 } } ;
-
-: <polygon-gadget> ( color points -- gadget )
- dup max-dim
- >r <polygon> <gadget> r> over set-rect-dim
- [ set-gadget-interior ] keep ;
-
-! Font rendering
-SYMBOL: font-renderer
-
-HOOK: open-font font-renderer ( font -- open-font )
-
-HOOK: string-width font-renderer ( open-font string -- w )
-
-HOOK: string-height font-renderer ( open-font string -- h )
-
-HOOK: draw-string font-renderer ( font string loc -- )
-
-HOOK: x>offset font-renderer ( x open-font string -- n )
-
-HOOK: free-fonts font-renderer ( world -- )
-
-: text-height ( open-font text -- n )
- dup string? [
- string-height
- ] [
- [ string-height ] with map sum
- ] if ;
-
-: text-width ( open-font text -- n )
- dup string? [
- string-width
- ] [
- 0 -rot [ string-width max ] with each
- ] if ;
-
-: text-dim ( open-font text -- dim )
- [ text-width ] 2keep text-height 2array ;
-
-: draw-text ( font text loc -- )
- over string? [
- draw-string
- ] [
- [
- [
- 2dup { 0 0 } draw-string
- >r open-font r> string-height
- 0.0 swap 0.0 glTranslated
- ] with each
- ] with-translation
- ] if ;
+++ /dev/null
-Support for rendering gadgets via OpenGL
+++ /dev/null
-Factor's graphical user interface framework
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: ui.tools.browser.tests
-USING: tools.test tools.test.ui ui.tools.browser ;
-
-\ <browser-gadget> must-infer
-[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 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 ;
-IN: ui.tools.browser
-
-TUPLE: browser-gadget < track pane history ;
-
-: show-help ( link help -- )
- dup history>> add-history
- >r >link r> history>> set-model ;
-
-: <help-pane> ( browser-gadget -- gadget )
- history>> [ [ help ] curry try ] <pane-control> ;
-
-: init-history ( browser-gadget -- )
- "handbook" >link <history> >>history drop ;
-
-: <browser-gadget> ( -- gadget )
- { 0 1 } browser-gadget new-track
- dup init-history
- dup <toolbar> f track-add
- dup <help-pane> >>pane
- dup pane>> <scroller> 1 track-add ;
-
-M: browser-gadget call-tool* show-help ;
-
-M: browser-gadget tool-scroller
- pane>> find-scroller ;
-
-M: browser-gadget graft*
- [ add-definition-observer ] [ call-next-method ] bi ;
-
-M: browser-gadget ungraft*
- [ call-next-method ] [ remove-definition-observer ] bi ;
-
-: showing-definition? ( defspec assoc -- ? )
- [ key? ] 2keep
- [ >r dup word-link? [ link-name ] when r> key? ] 2keep
- >r dup vocab-link? [ vocab ] when r> key?
- or or ;
-
-M: browser-gadget definitions-changed ( assoc browser -- )
- history>>
- dup model-value rot showing-definition?
- [ notify-connections ] [ drop ] if ;
-
-: help-action ( browser-gadget -- link )
- history>> model-value >link ;
-
-: com-follow ( link -- ) browser-gadget call-tool ;
-
-: com-back ( browser -- ) history>> go-back ;
-
-: com-forward ( browser -- ) history>> go-forward ;
-
-: com-documentation ( browser -- ) "handbook" swap show-help ;
-
-: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
-
-: browser-help ( -- ) "ui-browser" help-window ;
-
-\ browser-help H{ { +nullary+ t } } define-command
-
-browser-gadget "toolbar" f {
- { T{ key-down f { A+ } "b" } com-back }
- { T{ key-down f { A+ } "f" } com-forward }
- { T{ key-down f { A+ } "h" } com-documentation }
- { T{ key-down f { A+ } "v" } com-vocabularies }
- { T{ key-down f f "F1" } browser-help }
-} define-command-map
-
-browser-gadget "multi-touch" f {
- { T{ left-action } com-back }
- { T{ right-action } com-forward }
-} define-command-map
+++ /dev/null
-Graphical help browser
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: ui.gadgets help.markup help.syntax kernel quotations
-continuations debugger ui ;
-IN: ui.tools.debugger
-
-HELP: <debugger>
-{ $values { "error" "an error" } { "restarts" "a sequence of " { $link restart } " instances" } { "restart-hook" "a quotation with stack effect " { $snippet "( list -- )" } } { "gadget" "a new " { $link gadget } } }
-{ $description
- "Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
-} ;
-
-{ <debugger> debugger-window ui-try } related-words
-
-HELP: debugger-window
-{ $values { "error" "an error" } }
-{ $description "Opens a window with a description of the error." } ;
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
- ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
- ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
- ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
- ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
- models namespaces sequences sequences words continuations
- debugger prettyprint ui.tools.traceback help editors ;
-
-IN: ui.tools.debugger
-
-: <restart-list> ( restarts restart-hook -- gadget )
- [ restart-name ] rot <model> <list> ;
-
-TUPLE: debugger < track restarts ;
-
-: <debugger-display> ( restart-list error -- gadget )
- <filled-pile>
- <pane>
- swapd tuck [ print-error ] with-pane
- add-gadget
-
- swap add-gadget ;
-
-: <debugger> ( error restarts restart-hook -- gadget )
- { 0 1 } debugger new-track
- dup <toolbar> f track-add
- -rot <restart-list> >>restarts
- dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
-
-M: debugger focusable-child* debugger-restarts ;
-
-: debugger-window ( error -- )
- #! No restarts for the debugger window
- f [ drop ] <debugger> "Error" open-window ;
-
-[ debugger-window ] ui-error-hook set-global
-
-M: world-error error.
- "An error occurred while drawing the world " write
- dup world>> pprint-short "." print
- "This world has been deactivated to prevent cascading errors." print
- error>> error. ;
-
-debugger "gestures" f {
- { T{ button-down } request-focus }
-} define-command-map
-
-: com-traceback ( -- ) error-continuation get traceback-window ;
-
-\ com-traceback H{ { +nullary+ t } } define-command
-
-\ :help H{ { +nullary+ t } { +listener+ t } } define-command
-
-\ :edit H{ { +nullary+ t } { +listener+ t } } define-command
-
-debugger "toolbar" f {
- { T{ key-down f f "s" } com-traceback }
- { T{ key-down f f "h" } :help }
- { T{ key-down f f "e" } :edit }
-} define-command-map
+++ /dev/null
-Graphical error display
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: ui.tools.deploy
-
-HELP: deploy-tool
-{ $values { "vocab" "a vocabulary specifier" } }
-{ $description "Opens the graphical deployment tool for the specified vocabulary." }
-{ $examples { $code "\"tetris\" deploy-tool" } } ;
-
-ARTICLE: "ui.tools.deploy" "Application deployment UI tool"
-"The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically."
-$nl
-"To start the tool, pass a vocabulary name to a word:"
-{ $subsection deploy-tool }
-"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu."
-{ $see-also "tools.deploy" } ;
-
-ABOUT: "ui.tools.deploy"
+++ /dev/null
-! Copyright (C) 2007 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
- namespaces 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 ;
-
-IN: ui.tools.deploy
-
-TUPLE: deploy-gadget < pack vocab settings ;
-
-: bundle-name ( parent -- parent )
- deploy-name get <field>
- "Executable name:" label-on-left add-gadget ;
-
-: deploy-ui ( parent -- parent )
- deploy-ui? get
- "Include user interface framework" <checkbox> add-gadget ;
-
-: exit-when-windows-closed ( parent -- parent )
- "stop-after-last-window?" get
- "Exit when last UI window closed" <checkbox> add-gadget ;
-
-: io-settings ( parent -- parent )
- "Input/output support:" <label> add-gadget
- deploy-io get deploy-io-options <radio-buttons> add-gadget ;
-
-: reflection-settings ( parent -- parent )
- "Reflection support:" <label> add-gadget
- deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
-
-: advanced-settings ( parent -- parent )
- "Advanced:" <label> add-gadget
- deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
- deploy-math? get "Rational and complex number support" <checkbox> add-gadget
- deploy-threads? get "Threading support" <checkbox> add-gadget
- deploy-random? get "Random number generator support" <checkbox> add-gadget
- deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
- deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
- deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
-
-: deploy-settings-theme ( gadget -- gadget )
- { 10 10 } >>gap
- 1 >>fill ;
-
-: <deploy-settings> ( vocab -- control )
- default-config [ <model> ] assoc-map
- [
- <pile>
- bundle-name
- deploy-ui
- os macosx? [ exit-when-windows-closed ] when
- io-settings
- reflection-settings
- advanced-settings
-
- deploy-settings-theme
- namespace <mapping> over set-gadget-model
- ]
- bind ;
-
-: find-deploy-gadget ( gadget -- deploy-gadget )
- [ deploy-gadget? ] find-parent ;
-
-: find-deploy-vocab ( gadget -- vocab )
- find-deploy-gadget deploy-gadget-vocab ;
-
-: find-deploy-config ( gadget -- config )
- find-deploy-vocab deploy-config ;
-
-: find-deploy-settings ( gadget -- settings )
- find-deploy-gadget deploy-gadget-settings ;
-
-: com-revert ( gadget -- )
- dup find-deploy-config
- swap find-deploy-settings set-control-value ;
-
-: com-save ( gadget -- )
- dup find-deploy-settings control-value
- swap find-deploy-vocab set-deploy-config ;
-
-: com-deploy ( gadget -- )
- dup com-save
- dup find-deploy-vocab [ deploy ] curry call-listener
- close-window ;
-
-: com-help ( -- )
- "ui.tools.deploy" help-window ;
-
-\ com-help H{
- { +nullary+ t }
-} define-command
-
-: com-close ( gadget -- )
- close-window ;
-
-deploy-gadget "toolbar" f {
- { f com-close }
- { f com-help }
- { f com-revert }
- { f com-save }
- { T{ key-down f f "RET" } com-deploy }
-} define-command-map
-
-: <deploy-gadget> ( vocab -- gadget )
- deploy-gadget new-gadget
- over >>vocab
- { 0 1 } >>orientation
- swap <deploy-settings> >>settings
- dup settings>> add-gadget
- dup <toolbar> { 10 10 } >>gap add-gadget
- deploy-settings-theme
- dup com-revert ;
-
-: deploy-tool ( vocab -- )
- vocab-name dup <deploy-gadget> 10 <border>
- "Deploying \"" rot "\"" 3append open-window ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2008 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 ;
-IN: ui.tools.inspector
-
-TUPLE: inspector-gadget < track object pane ;
-
-: refresh ( inspector -- )
- [ object>> ] [ pane>> ] bi [
- +editable+ on
- +number-rows+ on
- describe
- ] with-pane ;
-
-: <inspector-gadget> ( -- gadget )
- { 0 1 } inspector-gadget new-track
- dup <toolbar> f track-add
- <pane> >>pane
- dup pane>> <scroller> 1 track-add ;
-
-: inspect-object ( obj mirror keys inspector -- )
- 2nip swap >>object refresh ;
-
-\ &push H{ { +nullary+ t } { +listener+ t } } define-command
-
-\ &back H{ { +nullary+ t } { +listener+ t } } define-command
-
-\ &globals H{ { +nullary+ t } { +listener+ t } } define-command
-
-: inspector-help ( -- ) "ui-inspector" help-window ;
-
-\ inspector-help H{ { +nullary+ t } } define-command
-
-inspector-gadget "toolbar" f {
- { T{ update-object } refresh }
- { f &push }
- { f &back }
- { f &globals }
- { T{ key-down f f "F1" } inspector-help }
-} define-command-map
-
-inspector-gadget "multi-touch" f {
- { T{ left-action } &back }
-} define-command-map
-
-M: inspector-gadget tool-scroller
- inspector-gadget-pane find-scroller ;
+++ /dev/null
-Graphical object viewer and editor
+++ /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
-
-[ ] [ 1000 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 sleep ] unit-test
-
-[ ] [ "interactor" get evaluate-input ] unit-test
-
-[ ] [ 100 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 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 ;
-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 )
- editor-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 [
- [ gadget-model T{ one-word-elt } elt-string ] keep
- interactor-use assoc-stack
- ] [
- 2drop f
- ] if ;
-
-M: interactor model-changed
- 2dup help>> eq? [
- swap model-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 ] [ interactor-history adjoin ] if ;
-
-: interactor-continue ( obj interactor -- )
- mailbox>> mailbox-put ;
-
-: clear-input ( interactor -- ) gadget-model clear-doc ;
-
-: interactor-finish ( interactor -- )
- #! The spawn is a kludge to make it infer. Stupid.
- [ editor-string ] keep
- [ interactor-input. ] 2keep
- [ add-interactor-history ] keep
- [ clear-input ] curry "Clearing input" spawn drop ;
-
-: 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 ""
- ] [
- >r interactor-read dup [ "\n" join ] when r> 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 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 ;
-
-M: interactor pref-dim*
- [ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
- vmax ;
-
-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
+++ /dev/null
-USING: continuations documents ui.tools.interactor
-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 ;
-IN: ui.tools.listener.tests
-
-[ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
-
-[ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
-
-[ ] [ <listener-gadget> "listener" set ] unit-test
-
-"listener" get [
- [ "dup" ] [
- \ dup word-completion-string
- ] unit-test
-
- [ "equal?" ]
- [ \ array \ equal? method word-completion-string ] unit-test
-
- <pane> <interactor> "i" set
-
- [ t ] [ "i" get interactor? ] unit-test
-
- [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test
-
- [ ] [
- "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
- ] unit-test
-
- [ t ] [
- "i" get gadget-model doc-end
- "i" get editor-caret* =
- ] unit-test
-
- ! Race condition discovered by SimonRC
- [ ] [
- [
- "listener" get input>>
- [ stream-read-quot drop ]
- [ stream-read-quot drop ] bi
- ] "OH, HAI" spawn drop
- ] unit-test
-
- [ ] [ "listener" get clear-output ] unit-test
-
- [ ] [ "listener" get restart-listener ] unit-test
-
- [ ] [ 1000 sleep ] unit-test
-
- [ ] [ "listener" get com-end ] unit-test
-] with-grafted-gadget
+++ /dev/null
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: inspector ui.tools.interactor ui.tools.inspector
-ui.tools.workspace help.markup io io.styles
-kernel models namespaces parser quotations sequences ui.commands
-ui.gadgets ui.gadgets.editors ui.gadgets.labelled
-ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.operations vocabs words
-prettyprint listener debugger threads boxes concurrency.flags
-math arrays generic accessors combinators assocs ;
-IN: ui.tools.listener
-
-TUPLE: listener-gadget < track input output stack ;
-
-: listener-output, ( listener -- listener )
- <scrolling-pane> >>output
- dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
-
-: listener-streams ( listener -- input output )
- [ input>> ] [ output>> <pane-stream> ] bi ;
-
-: <listener-input> ( listener -- gadget )
- output>> <pane-stream> <interactor> ;
-
-: listener-input, ( listener -- listener )
- dup <listener-input> >>input
- dup input>>
- { 0 100 } <limited-scroller>
- "Input" <labelled-gadget>
- f track-add ;
-
-: welcome. ( -- )
- "If this is your first time with Factor, please read the " print
- "handbook" ($link) "." print nl ;
-
-M: listener-gadget focusable-child*
- input>> ;
-
-M: listener-gadget call-tool* ( input listener -- )
- >r string>> r> input>> set-editor-string ;
-
-M: listener-gadget tool-scroller
- output>> find-scroller ;
-
-: wait-for-listener ( listener -- )
- #! Wait for the listener to start.
- input>> flag>> wait-for-flag ;
-
-: workspace-busy? ( workspace -- ? )
- listener>> input>> interactor-busy? ;
-
-: listener-input ( string -- )
- get-workspace listener>> input>> set-editor-string ;
-
-: (call-listener) ( quot listener -- )
- input>> interactor-call ;
-
-: call-listener ( quot -- )
- [ workspace-busy? not ] get-workspace* listener>>
- [ dup wait-for-listener (call-listener) ] 2curry
- "Listener call" spawn drop ;
-
-M: listener-command invoke-command ( target command -- )
- command-quot call-listener ;
-
-M: listener-operation invoke-command ( target command -- )
- [ operation-hook call ] keep operation-quot call-listener ;
-
-: eval-listener ( string -- )
- get-workspace
- listener>> input>> [ set-editor-string ] keep
- evaluate-input ;
-
-: listener-run-files ( seq -- )
- dup empty? [
- drop
- ] [
- [ [ run-file ] each ] curry call-listener
- ] if ;
-
-: com-end ( listener -- )
- input>> interactor-eof ;
-
-: clear-output ( listener -- )
- output>> pane-clear ;
-
-\ clear-output H{ { +listener+ t } } define-command
-
-: 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>> [
- 2dup assoc-stack pick = [ 2drop ] [
- >r vocabulary>> vocab-words r> push
- ] if
- ] [ 2drop ] if ;
-
-: insert-word ( word -- )
- get-workspace workspace-listener input>>
- [ >r word-completion-string r> user-input ]
- [ interactor-use use-if-necessary ]
- 2bi ;
-
-: quot-action ( interactor -- lines )
- dup control-value
- dup "\n" join pick add-interactor-history
- swap select-all ;
-
-TUPLE: stack-display < track ;
-
-: <stack-display> ( workspace -- gadget )
- listener>>
- { 0 1 } stack-display new-track
- over <toolbar> f track-add
- swap
- stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
- 1 track-add ;
-
-M: stack-display tool-scroller
- find-workspace workspace-listener tool-scroller ;
-
-: ui-listener-hook ( listener -- )
- >r datastack r> listener-gadget-stack set-model ;
-
-: ui-error-hook ( error listener -- )
- find-workspace debugger-popup ;
-
-: ui-inspector-hook ( obj listener -- )
- find-workspace inspector-gadget
- swap show-tool inspect-object ;
-
-: listener-thread ( listener -- )
- dup listener-streams [
- [ [ ui-listener-hook ] curry listener-hook set ]
- [ [ ui-error-hook ] curry error-hook set ]
- [ [ ui-inspector-hook ] curry inspector-hook set ] tri
- welcome.
- listener
- ] with-streams* ;
-
-: start-listener-thread ( listener -- )
- [
- [ input>> register-self ] [ listener-thread ] bi
- ] curry "Listener" spawn drop ;
-
-: restart-listener ( listener -- )
- #! Returns when listener is ready to receive input.
- {
- [ com-end ]
- [ clear-output ]
- [ input>> clear-input ]
- [ start-listener-thread ]
- [ wait-for-listener ]
- } cleave ;
-
-: init-listener ( listener -- )
- f <model> swap set-listener-gadget-stack ;
-
-: <listener-gadget> ( -- gadget )
- { 0 1 } listener-gadget new-track
- dup init-listener
- listener-output,
- listener-input, ;
-
-: listener-help ( -- ) "ui-listener" help-window ;
-
-\ listener-help H{ { +nullary+ t } } define-command
-
-listener-gadget "toolbar" f {
- { f restart-listener }
- { T{ key-down f f "CLEAR" } clear-output }
- { T{ key-down f { C+ } "CLEAR" } clear-stack }
- { T{ key-down f { C+ } "d" } com-end }
- { T{ key-down f f "F1" } listener-help }
-} define-command-map
-
-M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
- 3dup drop swap find-workspace workspace-page handle-gesture
- [ default-gesture-handler ] [ 3drop f ] if ;
-
-M: listener-gadget graft*
- [ call-next-method ] [ restart-listener ] bi ;
-
-M: listener-gadget ungraft*
- [ com-end ] [ call-next-method ] bi ;
+++ /dev/null
-Graphical code evaluator
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2006, 2007 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 inference summary inspector io.files 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 ;
-IN: ui.tools.operations
-
-V{ } clone operations set-global
-
-! Objects
-[ drop t ] \ inspect H{
- { +primary+ t }
- { +listener+ t }
-} define-operation
-
-: com-prettyprint ( obj -- ) . ;
-
-[ drop t ] \ com-prettyprint H{
- { +listener+ t }
-} define-operation
-
-: com-push ( obj -- obj ) ;
-
-[ drop t ] \ com-push H{
- { +listener+ t }
-} define-operation
-
-: com-unparse ( obj -- ) unparse listener-input ;
-
-[ drop t ] \ com-unparse H{ } define-operation
-
-! Input
-
-: com-input ( obj -- ) string>> listener-input ;
-
-[ input? ] \ com-input H{
- { +primary+ t }
- { +secondary+ t }
-} define-operation
-
-! Restart
-[ restart? ] \ restart H{
- { +primary+ t }
- { +secondary+ t }
- { +listener+ t }
-} define-operation
-
-! Continuation
-[ continuation? ] \ traceback-window H{
- { +primary+ t }
- { +secondary+ t }
-} define-operation
-
-! Pathnames
-: edit-file ( pathname -- ) edit ;
-
-[ pathname? ] \ edit-file H{
- { +keyboard+ T{ key-down f { C+ } "E" } }
- { +primary+ t }
- { +secondary+ t }
- { +listener+ t }
-} define-operation
-
-UNION: definition word method-spec link vocab vocab-link ;
-
-[ definition? ] \ edit H{
- { +keyboard+ T{ key-down f { C+ } "E" } }
- { +listener+ t }
-} define-operation
-
-: com-forget ( defspec -- )
- [ forget ] with-compilation-unit ;
-
-[ definition? ] \ com-forget H{ } define-operation
-
-! Words
-[ word? ] \ insert-word H{
- { +secondary+ t }
-} define-operation
-
-[ topic? ] \ com-follow H{
- { +keyboard+ T{ key-down f { C+ } "H" } }
- { +primary+ t }
-} define-operation
-
-: com-usage ( word -- )
- get-workspace swap show-word-usage ;
-
-[ word? ] \ com-usage H{
- { +keyboard+ T{ key-down f { C+ } "U" } }
-} define-operation
-
-[ word? ] \ fix H{
- { +keyboard+ T{ key-down f { C+ } "F" } }
- { +listener+ t }
-} define-operation
-
-[ word? ] \ watch H{ } define-operation
-
-[ word? ] \ breakpoint H{ } define-operation
-
-GENERIC: com-stack-effect ( obj -- )
-
-M: quotation com-stack-effect infer. ;
-
-M: word com-stack-effect def>> com-stack-effect ;
-
-[ word? ] \ com-stack-effect H{
- { +listener+ t }
-} define-operation
-
-! Vocabularies
-: com-vocab-words ( vocab -- )
- get-workspace swap show-vocab-words ;
-
-[ vocab? ] \ com-vocab-words H{
- { +secondary+ t }
- { +keyboard+ T{ key-down f { C+ } "B" } }
-} define-operation
-
-: com-enter-in ( vocab -- ) vocab-name set-in ;
-
-[ vocab? ] \ com-enter-in H{
- { +keyboard+ T{ key-down f { C+ } "I" } }
- { +listener+ t }
-} define-operation
-
-: com-use-vocab ( vocab -- ) vocab-name use+ ;
-
-[ vocab-spec? ] \ com-use-vocab H{
- { +secondary+ t }
- { +listener+ t }
-} 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
-
-[ vocab-spec? ] \ deploy-tool H{ } define-operation
-
-! Quotations
-[ quotation? ] \ com-stack-effect H{
- { +keyboard+ T{ key-down f { C+ } "i" } }
- { +listener+ t }
-} define-operation
-
-[ quotation? ] \ walk H{
- { +keyboard+ T{ key-down f { C+ } "w" } }
- { +listener+ t }
-} define-operation
-
-[ quotation? ] \ time H{
- { +keyboard+ T{ key-down f { C+ } "t" } }
- { +listener+ t }
-} define-operation
-
-: com-show-profile ( workspace -- )
- profiler-gadget call-tool ;
-
-: com-profile ( quot -- ) profile f com-show-profile ;
-
-[ quotation? ] \ com-profile H{
- { +keyboard+ T{ key-down f { C+ } "r" } }
- { +listener+ t }
-} define-operation
-
-! Profiler presentations
-[ dup usage-profile? swap vocab-profile? or ]
-\ com-show-profile H{ { +primary+ t } } define-operation
-
-! Operations -> commands
-source-editor
-"word"
-"These commands operate on the Factor word named by the token at the caret position."
-\ selected-word
-[ selected-word ]
-[ dup search [ ] [ no-word ] ?if ]
-define-operation-map
-
-interactor
-"quotation"
-"These commands operate on the entire contents of the input area."
-[ ]
-[ quot-action ]
-[ [ parse-lines ] with-compilation-unit ]
-define-operation-map
+++ /dev/null
-Standard presentation operations
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2007 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 ;
-IN: ui.tools.profiler
-
-TUPLE: profiler-gadget < track pane ;
-
-: <profiler-gadget> ( -- gadget )
- { 0 1 } profiler-gadget new-track
- dup <toolbar> f track-add
- <pane> >>pane
- dup pane>> <scroller> 1 track-add ;
-
-: with-profiler-pane ( gadget quot -- )
- >r profiler-gadget-pane r> with-pane ;
-
-: com-full-profile ( gadget -- )
- [ profile. ] with-profiler-pane ;
-
-: com-vocabs-profile ( gadget -- )
- [ vocabs-profile. ] with-profiler-pane ;
-
-: com-method-profile ( gadget -- )
- [ method-profile. ] with-profiler-pane ;
-
-: profiler-help ( -- ) "ui-profiler" help-window ;
-
-\ 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
- usage-profile-word [ usage-profile. ] curry ;
-
-M: vocab-profile profiler-presentation
- vocab-profile-vocab [ vocab-profile. ] curry ;
-
-M: f profiler-presentation
- drop [ vocabs-profile. ] ;
-
-M: profiler-gadget call-tool* ( obj gadget -- )
- swap profiler-presentation with-profiler-pane ;
+++ /dev/null
-Graphical call profiler
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: assocs ui.tools.search help.topics io.files io.styles
-kernel namespaces sequences source-files threads
-tools.test ui.gadgets ui.gestures vocabs
-vocabs.loader words tools.test.ui debugger ;
-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 sleep
- live-search-list control-value
- ] with-grafted-gadget ;
-
-: test-live-search ( gadget quot -- ? )
- >r update-live-search dup assert-non-empty r> 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 live-search-field set-control-value
- 300 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 ui.tools.interactor ui.tools.listener
-ui.tools.workspace help help.topics io.files io.styles kernel
-models models.delay models.filter namespaces prettyprint
-quotations sequences sorting source-files definitions strings
-tools.completion tools.crossref classes.tuple ui.commands
-ui.gadgets ui.gadgets.editors ui.gadgets.lists
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
-vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
-;
-IN: ui.tools.search
-
-TUPLE: live-search < track field list ;
-
-: search-value ( live-search -- value )
- live-search-list list-value ;
-
-: search-gesture ( gesture live-search -- operation/f )
- search-value object-operations
- [ operation-gesture = ] with find nip ;
-
-M: live-search handle-gesture* ( gadget gesture delegate -- ? )
- drop over search-gesture dup [
- over find-workspace hide-popup
- >r search-value r> invoke-command f
- ] [
- 2drop t
- ] if ;
-
-: find-live-search ( gadget -- search )
- [ [ live-search? ] is? ] find-parent ;
-
-: find-search-list ( gadget -- list )
- find-live-search 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 -- live-search filter )
- >r dup field>> model>> ! live-search model :: producer
- ui-running? [ 1/5 seconds <delay> ] when
- [ "\n" join ] r> append <filter> ;
-
-: <search-list> ( live-search seq limited? presenter -- live-search list )
- >r
- [ limited-completions ] [ completions ] ? curry
- <search-model>
- >r [ find-workspace hide-popup ] r> r>
- swap <list> ;
-
-: <live-search> ( string seq limited? presenter -- gadget )
- { 0 1 } live-search new-track
- <search-field> >>field
- dup field>> f track-add
- -roll <search-list> >>list
- dup list>> <scroller> 1 track-add
-
- swap
- over field>> set-editor-string
- dup field>> end-of-document ;
-
-M: live-search focusable-child* live-search-field ;
-
-M: live-search pref-dim* drop { 400 200 } ;
-
-: current-word ( workspace -- string )
- workspace-listener listener-gadget-input selected-word ;
-
-: definition-candidates ( words -- candidates )
- [ dup synopsis >lower ] { } map>assoc sort-values ;
-
-: <definition-search> ( string words limited? -- gadget )
- >r definition-candidates r> [ synopsis ] <live-search> ;
-
-: word-candidates ( words -- candidates )
- [ dup name>> >lower ] { } map>assoc ;
-
-: <word-search> ( string words limited? -- gadget )
- >r word-candidates r> [ synopsis ] <live-search> ;
-
-: com-words ( workspace -- )
- dup current-word all-words t <word-search>
- "Word search" show-titled-popup ;
-
-: show-vocab-words ( workspace vocab -- )
- "" over words natural-sort f <word-search>
- "Words in " rot vocab-name append show-titled-popup ;
-
-: show-word-usage ( workspace word -- )
- "" over smart-usage f <definition-search>
- "Words and methods using " rot name>> append
- 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 [ pathname-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 -- )
- "" over vocab-files <source-file-search>
- "Source files in " rot vocab-name append 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 [ input-string ] <live-search> ;
-
-: listener-history ( listener -- seq )
- listener-gadget-input interactor-history <reversed> ;
-
-: com-history ( workspace -- )
- "" over workspace-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
+++ /dev/null
-Graphical developer tools
+++ /dev/null
-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 ;
-IN: ui.tools
-
-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
-"When you move the mouse over a presentation, it is highlighted with a rectangular border and a short summary of the object being presented is shown in the status bar (the summary is produced using the " { $link summary } " word)."
-$nl
-"Clicking a presentation with the left mouse button invokes a default operation, which usually views the object in some way. For example, clicking a presentation of a word jumps to the word definition in the " { $link "ui-browser" } "."
-$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 } "), and a stack display kept up to date using a " { $link listener-hook } "." ;
-
-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 } "." ;
-
-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" } ;
-
-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."
-$nl
-"First, a standard Mac-style menu bar is provided, which offers the bare minimum of what you would expect from a Mac OS X application."
-$nl
-"Dropping a source file onto the Factor icon in the dock runs the source file in the listener."
-$nl
-"If you install " { $strong "Factor.app" } " in your " { $strong "Applications" } " folder, then other applications will be able to call Factor via the System Services feature. For example, you can select some text in " { $strong "TextEdit.app" } ", then invoke the " { $strong "TextEdit->Services->Factor->Evaluate Selection" } " menu item, which will replace the selected text with the result of evaluating it in Factor."
-
-;
-
-ARTICLE: "ui-tool-tutorial" "UI tool tutorial"
-"The following is an example of a typical session with the UI which should give you a taste of its power:"
-{ $list
- { "You decide to refactor some code, and move a few words from a source file you have already loaded, into a new source file." }
- { "You press " { $operation edit } " in the listener, which displays a gadget where you can type part of a loaded file's name, and then press " { $snippet "RET" } " when the correct completion is highlighted. This opens the file in your editor." }
- { "You refactor your words, move them to a new source file, and load the new file using " { $link run-file } "." }
- { "Interactively testing the new code reveals a problem with one particular code snippet, so you enter it in the listener's input area, and press " { $operation walk } " to invoke the single stepper." }
- { "Single stepping through the code makes the problem obvious, so you right-click on a presentation of the broken word in the stepper, and choose " { $strong "Edit" } " from the menu." }
- { "After fixing the problem in the source editor, you right click on the word in the stepper and invoke " { $strong "Reload" } " from the menu." }
-} ;
-
-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"
-{ $command-map workspace "tool-switching" }
-{ $command-map workspace "scrolling" }
-{ $command-map workspace "workflow" }
-{ $command-map workspace "multi-touch" }
-{ $heading "Implementation" }
-"Workspaces are instances of " { $link workspace } "." ;
-
-ARTICLE: "ui-tools" "UI development tools"
-"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
-$nl
-"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
-{ $subsection "ui-tool-tutorial" }
-{ $subsection "ui-workspace-keys" }
-{ $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:"
-{ $subsection "ui-cocoa" } ;
-
-ABOUT: "ui-tools"
+++ /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.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 workspace-book gadget-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 workspace-popup closable-gadget-content
- live-search-list gadget-child "p" set ] unit-test
-
- [ t ] [ "p" get presentation? ] unit-test
-
- [ ] [ "p" get <operations-menu> gadget-child gadget-child "c" set ] unit-test
-
- [ ] [ notify-queued ] unit-test
-
- [ t ] [ "c" get button? ] unit-test
-
- [ ] [
- "w" get workspace-listener listener-gadget-input
- 3 handle-parse-error
- ] unit-test
-
- [ ] [ notify-queued ] unit-test
-] with-grafted-gadget
+++ /dev/null
-! Copyright (C) 2006, 2008 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 ;
-IN: ui.tools
-
-: <workspace-tabs> ( workspace -- tabs )
- model>>
- "tool-switching" workspace command-map commands>>
- [ command-string ] { } assoc>map <enum> >alist
- <toggle-buttons> ;
-
-: <workspace-book> ( workspace -- gadget )
-
- dup
- <stack-display>
- <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
-
- dup <workspace-tabs> f track-add
- dup book>> 1/5 track-add
- dup listener>> 4/5 track-add
- dup <toolbar> f track-add ;
-
-: resize-workspace ( workspace -- )
- dup track-sizes over control-value zero? [
- 1/5 1 pick set-nth
- 4/5 2 rot set-nth
- ] [
- 2/3 1 pick set-nth
- 1/3 2 rot set-nth
- ] if relayout ;
-
-M: workspace model-changed
- nip
- dup workspace-listener listener-gadget-output scroll>bottom
- dup resize-workspace
- request-focus ;
-
-[ workspace-window ] ui-hook set-global
-
-: com-listener ( workspace -- ) stack-display select-tool ;
-
-: com-browser ( workspace -- ) browser-gadget select-tool ;
-
-: com-inspector ( workspace -- ) inspector-gadget select-tool ;
-
-: com-profiler ( workspace -- ) profiler-gadget 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 }
-} 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 }
- { 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 ] curry call-listener ;
-
-traceback-gadget "toolbar" f {
- { T{ key-down f f "v" } variables }
- { T{ key-down f f "n" } inspect-continuation }
-} define-command-map
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Traceback gadgets display a continuation in human-readable form
+++ /dev/null
-! Copyright (C) 2006, 2008 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 ;
-
-IN: ui.tools.traceback
-
-: <callstack-display> ( model -- gadget )
- [ [ continuation-call callstack. ] when* ]
- t "Call stack" <labelled-pane> ;
-
-: <datastack-display> ( model -- gadget )
- [ [ continuation-data stack. ] when* ]
- t "Data stack" <labelled-pane> ;
-
-: <retainstack-display> ( model -- gadget )
- [ [ continuation-retain stack. ] when* ]
- t "Retain stack" <labelled-pane> ;
-
-TUPLE: traceback-gadget < track ;
-
-M: traceback-gadget pref-dim* drop { 550 600 } ;
-
-: <traceback-gadget> ( model -- gadget )
- { 0 1 } traceback-gadget new-track
- swap >>model
-
- dup model>>
- { 1 0 } <track>
- over <datastack-display> 1/2 track-add
- swap <retainstack-display> 1/2 track-add
- 1/3 track-add
-
- dup model>> <callstack-display> 2/3 track-add
-
- dup <toolbar> f track-add ;
-
-: <namestack-display> ( model -- gadget )
- [ [ continuation-name namestack. ] when* ]
- <pane-control> ;
-
-: <variables-gadget> ( model -- gadget )
- <namestack-display> { 400 400 } <limited-scroller> ;
-
-: variables ( traceback -- )
- gadget-model <variables-gadget>
- "Dynamic variables" open-status-window ;
-
-: traceback-window ( continuation -- )
- <model> <traceback-gadget> "Traceback" open-window ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Graphical code single stepper
+++ /dev/null
-IN: ui.tools.walker\r
-USING: help.markup help.syntax ui.commands ui.operations\r
-ui.render tools.walker sequences ;\r
-\r
-ARTICLE: "ui-walker-step" "Stepping through code"\r
-"If the current position points to a word, the various stepping commands behave as follows:"\r
-{ $list\r
- { { $link com-step } " executes the word and moves the current position one word further." }\r
- { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." }\r
- { { $link com-out } " executes until the end of the current quotation." }\r
-}\r
-"If the current position points to a literal, the various stepping commands behave as follows:"\r
-{ $list\r
- { { $link com-step } " pushes the literal on the data stack." }\r
- { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." }\r
- { { $link com-out } " executes until the end of the current quotation." }\r
-}\r
-"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:"\r
-{ $code "{ 10 20 30 } [ 3 + . ] each" }\r
-"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:"\r
-{ $code "[ break 3 + . ]" }\r
-"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit."\r
-$nl\r
-"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;\r
-\r
-ARTICLE: "breakpoints" "Setting breakpoints"\r
-"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "."\r
-$nl\r
-"Breakpoints can be inserted directly into code:"\r
-{ $subsection break }\r
-"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;\r
-\r
-ARTICLE: "ui-walker" "UI walker"\r
-"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."\r
-$nl\r
-"Walkers are instances of " { $link walker-gadget } "."\r
-{ $subsection "ui-walker-step" }\r
-{ $subsection "breakpoints" }\r
-{ $command-map walker-gadget "toolbar" } ;\r
-\r
-ABOUT: "ui-walker"\r
+++ /dev/null
-USING: ui.tools.walker tools.test ;
-IN: ui.tools.walker.tests
-
-\ <walker-gadget> must-infer
+++ /dev/null
-! Copyright (C) 2006, 2008 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
-ui.gadgets.labels ui threads namespaces tools.walker assocs
-combinators ;
-IN: ui.tools.walker
-
-TUPLE: walker-gadget < track
-status continuation thread
-traceback
-closing? ;
-
-: walker-command ( walker msg -- )
- swap
- dup thread>> thread-registered?
- [ thread>> send-synchronous drop ]
- [ 2drop ]
- if ;
-
-: com-step ( walker -- ) step walker-command ;
-
-: com-into ( walker -- ) step-into walker-command ;
-
-: com-out ( walker -- ) step-out walker-command ;
-
-: com-back ( walker -- ) step-back walker-command ;
-
-: com-continue ( walker -- ) step-all walker-command ;
-
-: com-abandon ( walker -- ) abandon walker-command ;
-
-M: walker-gadget ungraft*
- [ t >>closing? drop ] [ com-continue ] [ call-next-method ] tri ;
-
-M: walker-gadget focusable-child*
- traceback>> ;
-
-: walker-state-string ( status thread -- string )
- [
- "Thread: " %
- dup thread-name %
- " (" %
- swap {
- { +stopped+ "Stopped" }
- { +suspended+ "Suspended" }
- { +running+ "Running" }
- } at %
- ")" %
- drop
- ] "" make ;
-
-: <thread-status> ( model thread -- gadget )
- [ walker-state-string ] curry <filter> <label-control> ;
-
-: <walker-gadget> ( status continuation thread -- gadget )
- { 0 1 } walker-gadget new-track
- swap >>thread
- swap >>continuation
- swap >>status
- dup continuation>> <traceback-gadget> >>traceback
-
- dup <toolbar> f track-add
- dup status>> self <thread-status> f track-add
- dup traceback>> 1 track-add ;
-
-: walker-help ( -- ) "ui-walker" help-window ;
-
-\ walker-help H{ { +nullary+ t } } define-command
-
-walker-gadget "toolbar" f {
- { T{ key-down f f "s" } com-step }
- { T{ key-down f f "i" } com-into }
- { T{ key-down f f "o" } com-out }
- { T{ key-down f f "b" } com-back }
- { T{ key-down f f "c" } com-continue }
- { T{ key-down f f "a" } com-abandon }
- { T{ key-down f f "d" } close-window }
- { T{ key-down f f "F1" } walker-help }
-} define-command-map
-
-: walker-for-thread? ( thread gadget -- ? )
- {
- { [ dup walker-gadget? not ] [ 2drop f ] }
- { [ dup walker-gadget-closing? ] [ 2drop f ] }
- [ thread>> eq? ]
- } cond ;
-
-: find-walker-window ( thread -- world/f )
- [ swap walker-for-thread? ] curry find-window ;
-
-: walker-window ( status continuation thread -- )
- [ <walker-gadget> ] [ thread-name ] bi open-status-window ;
-
-[
- dup find-walker-window dup
- [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if
-] show-walker-hook set-global
+++ /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, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes continuations help help.topics kernel models
- sequences 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 assocs arrays namespaces accessors ;
-
-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 workspace-book gadget-model
- set-model ;
-
-: select-tool ( workspace class -- ) swap show-tool drop ;
-
-: get-workspace* ( quot -- workspace )
- [ >r dup workspace? r> [ drop f ] if ] curry 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-window ( topic -- )
- [
- <pane> [ [ help ] with-pane ] keep
- { 550 700 } <limited-scroller>
- ] keep
- article-title 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* drop workspace-dim get ;
-
-M: workspace focusable-child*
- dup workspace-popup [ ] [ workspace-listener ] ?if ;
-
-: workspace-page ( workspace -- gadget )
- workspace-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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Gadget tree traversal
+++ /dev/null
-IN: ui.traverse.tests
-USING: ui.gadgets ui.gadgets.labels namespaces sequences kernel
-math arrays tools.test io ui.gadgets.panes ui.traverse
-definitions compiler.units ;
-
-M: array gadget-children ;
-
-GENERIC: (flatten-tree) ( node -- )
-
-M: node (flatten-tree)
- node-children [ (flatten-tree) ] each ;
-
-M: object (flatten-tree) , ;
-
-: flatten-tree ( seq -- newseq )
- [ [ (flatten-tree) ] each ] { } make ;
-
-: gadgets-in-range ( frompath topath gadget -- seq )
- gadget-subtree flatten-tree ;
-
-[ { "a" "b" "c" "d" } ] [
- { 0 } { } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" "b" } ] [
- { } { 1 } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" } ] [
- { 0 } { 0 } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" "b" "c" } ] [
- { 0 } { 2 } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" "b" "c" "d" } ] [
- { 0 } { 3 } { "a" "b" "c" "d" } gadgets-in-range
-] unit-test
-
-[ { "a" "b" "c" "d" } ] [
- { 0 0 } { 0 3 } { { "a" "b" "c" "d" } } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" "e" } ] [
- { 0 1 } { 1 } { { "a" "b" "c" "d" } "e" } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" "e" "f" } ] [
- { 0 1 } { 1 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" { "e" "f" "g" } "h" "i" } ] [
- { 0 1 } { 2 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { "h" "i" } } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" { "e" "f" "g" } "h" } ] [
- { 0 1 } { 2 0 0 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
-] unit-test
-
-[ { "b" "c" "d" { "e" "f" "g" } "h" "i" } ] [
- { 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
-] unit-test
-
-[ { array gadget-children } forget ] with-compilation-unit
+++ /dev/null
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel math arrays io ui.gadgets
-generic combinators ;
-IN: ui.traverse
-
-TUPLE: node value children ;
-
-: traverse-step ( path gadget -- path' gadget' )
- >r unclip r> gadget-children ?nth ;
-
-: make-node ( quot -- ) { } make node boa , ; inline
-
-: traverse-to-path ( topath gadget -- )
- dup not [
- 2drop
- ] [
- over empty? [
- nip ,
- ] [
- [
- 2dup gadget-children swap first head-slice %
- tuck traverse-step traverse-to-path
- ] make-node
- ] if
- ] if ;
-
-: traverse-from-path ( frompath gadget -- )
- dup not [
- 2drop
- ] [
- over empty? [
- nip ,
- ] [
- [
- 2dup traverse-step traverse-from-path
- tuck gadget-children swap first 1+ tail-slice %
- ] make-node
- ] if
- ] if ;
-
-: traverse-pre ( frompath gadget -- )
- traverse-step traverse-from-path ;
-
-: (traverse-middle) ( frompath topath gadget -- )
- >r >r first 1+ r> first r> gadget-children <slice> % ;
-
-: traverse-post ( topath gadget -- )
- traverse-step traverse-to-path ;
-
-: traverse-middle ( frompath topath gadget -- )
- [
- 3dup nip traverse-pre
- 3dup (traverse-middle)
- 2dup traverse-post
- 2nip
- ] make-node ;
-
-DEFER: (gadget-subtree)
-
-: traverse-child ( frompath topath gadget -- )
- dup -roll [
- >r >r rest-slice r> r> traverse-step (gadget-subtree)
- ] make-node ;
-
-: (gadget-subtree) ( frompath topath gadget -- )
- {
- { [ dup not ] [ 3drop ] }
- { [ pick empty? pick empty? and ] [ 2nip , ] }
- { [ pick empty? ] [ rot drop traverse-to-path ] }
- { [ over empty? ] [ nip traverse-from-path ] }
- { [ pick first pick first = ] [ traverse-child ] }
- [ traverse-middle ]
- } cond ;
-
-: gadget-subtree ( frompath topath gadget -- seq )
- [ (gadget-subtree) ] { } make ;
-
-M: node gadget-text*
- dup node-children swap node-value gadget-seq-text ;
-
-: gadget-text-range ( frompath topath gadget -- str )
- gadget-subtree gadget-text ;
-
-: gadget-at-path ( parent path -- gadget )
- [ swap nth-gadget ] each ;
+++ /dev/null
-USING: help.markup help.syntax strings quotations debugger
-io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
-ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ;
-IN: ui
-
-HELP: windows
-{ $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
-
-{ windows open-window find-window } related-words
-
-HELP: open-window
-{ $values { "gadget" gadget } { "title" string } }
-{ $description "Opens a native window with the specified title." } ;
-
-HELP: set-fullscreen?
-{ $values { "?" "a boolean" } { "gadget" gadget } }
-{ $description "Sets and unsets fullscreen mode for the gadget's world." } ;
-
-HELP: fullscreen?
-{ $values { "gadget" gadget } { "?" "a boolean" } }
-{ $description "Queries the gadget's world to see if it is running in fullscreen mode." } ;
-
-{ fullscreen? set-fullscreen? } related-words
-
-HELP: find-window
-{ $values { "quot" "a quotation with stack effect " { $snippet "( world -- ? )" } } { "world" "a " { $link world } " or " { $link f } } }
-{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
-
-HELP: register-window
-{ $values { "world" world } { "handle" "a baackend-specific handle" } }
-{ $description "Adds a window to the global " { $link windows } " variable." }
-{ $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ;
-
-HELP: unregister-window
-{ $values { "handle" "a baackend-specific handle" } }
-{ $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: start-ui
-{ $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)
-{ $values { "world" world } }
-{ $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
-{ $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
-
-HELP: ui-try
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
-{ $notes "This is essentially a graphical variant of " { $link try } "." } ;
-
-ARTICLE: "ui-glossary" "UI glossary"
-{ $table
- { "color specifier"
- { "an array of four elements, all numbers between 0 and 1:"
- { $list
- "red"
- "green"
- "blue"
- "alpha - 0 is completely transparent, 1 is completely opaque"
- }
- }
- }
- { "dimension" "a pair of integers denoting pixel size on screen" }
- { "font specifier"
- { "an array of three elements:"
- { $list
- { "font family - one of " { $snippet "serif" } ", " { $snippet "sans-serif" } " or " { $snippet "monospace" } }
- { "font style - one of " { $link plain } ", " { $link bold } ", " { $link italic } " or " { $link bold-italic } }
- "font size in points"
- }
- }
- }
- { "gadget" { "a graphical element which responds to user input. Gadgets are tuples which (directly or indirectly) inherit from " { $link gadget } "." } }
- { "label specifier" { "a string, " { $link f } " or a gadget. See " { $link "ui.gadgets.buttons" } } }
- { "orientation specifier" { "one of " { $snippet "{ 0 1 }" } " or " { $snippet "{ 1 0 }" } ", with the former denoting vertical orientation and the latter denoting horizontal. Using a vector instead of symbolic constants allows these values to be directly useful in co-ordinate calculations" } }
- { "point" "a pair of integers denoting a pixel location on screen" }
-} ;
-
-ARTICLE: "building-ui" "Building user interfaces"
-"A gadget is a graphical element which responds to user input. Gadgets are implemented as tuples which (directly or indirectly) inherit from " { $link gadget } ", which in turn inherits from " { $link rect } "."
-{ $subsection gadget }
-"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget, stored in the " { $link gadget-parent } " slot."
-{ $subsection "ui-geometry" }
-{ $subsection "ui-layouts" }
-{ $subsection "gadgets" }
-{ $subsection "ui-windows" }
-{ $see-also "models" } ;
-
-ARTICLE: "gadgets" "Pre-made UI gadgets"
-{ $subsection "ui.gadgets.labels" }
-{ $subsection "gadgets-polygons" }
-{ $subsection "ui.gadgets.borders" }
-{ $subsection "ui.gadgets.labelled" }
-{ $subsection "ui.gadgets.buttons" }
-{ $subsection "ui.gadgets.sliders" }
-{ $subsection "ui.gadgets.scrollers" }
-{ $subsection "gadgets-editors" }
-{ $subsection "ui.gadgets.panes" }
-{ $subsection "ui.gadgets.presentations" }
-{ $subsection "ui.gadgets.lists" } ;
-
-ARTICLE: "ui-geometry" "Gadget geometry"
-"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
-{ $subsection rect }
-"Rectangles can be taken apart:"
-{ $subsection rect-loc }
-{ $subsection rect-dim }
-{ $subsection rect-bounds }
-{ $subsection rect-extent }
-"New rectangles can be created:"
-{ $subsection <zero-rect> }
-{ $subsection <rect> }
-{ $subsection <extent-rect> }
-"More utility words for working with rectangles:"
-{ $subsection offset-rect }
-{ $subsection rect-intersect }
-{ $subsection intersects? }
-"A gadget's bounding box is always relative to its parent:"
-{ $subsection gadget-parent }
-"Word for converting from a child gadget's co-ordinate system to a parent's:"
-{ $subsection relative-loc }
-{ $subsection screen-loc }
-"Hit testing:"
-{ $subsection pick-up }
-{ $subsection children-on } ;
-
-ARTICLE: "ui-windows" "Top-level windows"
-"Opening a top-level window:"
-{ $subsection open-window }
-"Finding top-level windows:"
-{ $subsection find-window }
-"Top-level windows are stored in a global variable:"
-{ $subsection windows }
-"When a gadget is displayed in a top-level window, or added to a parent which is already showing in a top-level window, a generic word is called allowing the gadget to perform initialization tasks:"
-{ $subsection graft* }
-"When the gadget is removed from a parent shown in a top-level window, or when the top-level window is closed, a corresponding generic word is called to clean up:"
-{ $subsection ungraft* }
-"The root of the gadget hierarchy in a window is a special gadget which is rarely operated on directly, but it is helpful to know it exists:"
-{ $subsection world } ;
-
-ARTICLE: "ui-backend" "Developing UI backends"
-"None of the words documented in this section should be called directly by user code. They are only of interest when developing new UI backends."
-{ $subsection "ui-backend-init" }
-{ $subsection "ui-backend-windows" }
-"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 word to start the UI:"
-{ $subsection ui }
-"This word should contain backend initialization, together with some boilerplate:"
-{ $code
- "IN: shells"
- ""
- ": ui"
- " ... backend-specific initialization ..."
- " start-ui"
- " ... more backend-specific initialization ..."
- " ... start event loop here ... ;"
-}
-"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."
-$nl
-"The event loop must not block, since otherwise other Factor threads and I/O will not run. Instead, it should poll for pending events, then call " { $link ui-wait } "." ;
-
-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:"
-{ $subsection open-world-window }
-"This word should create a native window, store some kind of handle in the " { $link world-handle } " slot, then call two words:"
-{ $subsection register-window }
-"The following words must also be implemented:"
-{ $subsection set-title }
-{ $subsection raise-window }
-"When a world needs to be redrawn, the UI will call a word automatically:"
-{ $subsection draw-world }
-"This word can also be called directly if the UI backend is notified by the window system that window contents have been invalidated. Before and after drawing, two words are called, which the UI backend must implement:"
-{ $subsection select-gl-context }
-{ $subsection flush-gl-context }
-"If the user clicks the window's close box, you must call the following word:"
-{ $subsection close-window } ;
-
-HELP: raise-window
-{ $values { "gadget" gadget } }
-{ $description "Makes the native window containing the given gadget the front-most window." } ;
-
-ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
-"A layout gadget is a gadget whose sole purpose is to contain other gadgets. Layout gadgets position and resize children according to a certain policy, taking the preferred size of the children into account. Gadget hierarchies are constructed by building up nested layouts."
-{ $subsection "ui-layout-basics" }
-{ $subsection "ui-layout-combinators" }
-"Common layout gadgets:"
-{ $subsection "ui-pack-layout" }
-{ $subsection "ui-track-layout" }
-{ $subsection "ui-grid-layout" }
-{ $subsection "ui-frame-layout" }
-{ $subsection "ui-book-layout" }
-"Advanced topics:"
-{ $subsection "ui-null-layout" }
-{ $subsection "ui-incremental-layout" }
-{ $subsection "ui-layout-impl" }
-{ $see-also "ui.gadgets.borders" } ;
-
-ARTICLE: "ui-layout-basics" "Layout basics"
-"Gadgets are arranged in a hierarchy, and all visible gadgets except for instances of " { $link world } " are contained in a parent gadget."
-$nl
-"Managing the gadget hierarchy:"
-{ $subsection add-gadget }
-{ $subsection unparent }
-{ $subsection add-gadgets }
-{ $subsection clear-gadget }
-"Working with gadget children:"
-{ $subsection gadget-children }
-{ $subsection gadget-child }
-{ $subsection nth-gadget }
-{ $subsection each-child }
-{ $subsection child? }
-"Working with gadget parents:"
-{ $subsection parents }
-{ $subsection each-parent }
-{ $subsection find-parent }
-"Adding children, removing children and performing certain other operations initiates relayout requests automatically. In other cases, relayout may have to be triggered explicitly. There is no harm from doing this several times in a row as consecutive relayout requests are coalesced."
-{ $subsection relayout }
-{ $subsection relayout-1 }
-"Gadgets implement a generic word to inform their parents of their preferred size:"
-{ $subsection pref-dim* }
-"To get a gadget's preferred size, do not call the above word, instead use " { $link pref-dim } ", which caches the result." ;
-
-ARTICLE: "ui-layout-combinators" "Creating layouts using combinators"
-"The " { $link make } " combinator provides a convenient way of constructing sequences by keeping the intermediate sequence off the stack until construction is done. The " { $link , } " and " { $link % } " words operate on this implicit sequence, reducing stack noise."
-$nl
-"Similar tools exist for constructing complex gadget hierarchies. Different words are used for different types of gadgets; see " { $link "ui-pack-layout" } ", " { $link "ui-track-layout" } " and " { $link "ui-frame-layout" } " for specifics. This section documents their common factors."
-;
-
-ARTICLE: "ui-null-layout" "Manual layouts"
-"When automatic layout is not appropriate, gadgets can be added to a parent with no layout policy, and then positioned and sized manually:"
-{ $subsection set-rect-loc } ;
-
-ARTICLE: "ui-layout-impl" "Implementing layout gadgets"
-"The relayout process proceeds top-down, with parents laying out their children, which in turn lay out their children. Custom layout policy is implemented by defining a method on a generic word:"
-{ $subsection layout* }
-"When a " { $link layout* } " method is called, the size and location of the gadget has already been determined by its parent, and the method's job is to lay out the gadget's children. Children can be positioned and resized with a pair of words:"
-{ $subsection set-rect-loc }
-"Some assorted utility words which are useful for implementing layout logic:"
-{ $subsection pref-dim }
-{ $subsection pref-dims }
-{ $subsection prefer }
-{ $subsection max-dim }
-{ $subsection dim-sum }
-{ $warning
- "When implementing the " { $link layout* } " generic word for a gadget which inherits from another layout, the " { $link children-on } " word might have to be re-implemented as well."
- $nl
- "For example, suppose you want a " { $link grid } " layout which also displays a popup gadget on top. The implementation of " { $link children-on } " for the " { $link grid } " class determines which children of the grid are visible at one time, and this will never include your popup, so it will not be rendered, nor will it respond to gestures. The solution is to re-implement " { $link children-on } " on your class."
-} ;
-
-ARTICLE: "new-gadgets" "Implementing new gadgets"
-"One of the goals of the Factor UI is to minimize the need to implement new types of gadgets by offering a highly reusable, orthogonal set of building blocks. However, in some cases implementing a new type of gadget is necessary, for example when writing a graphical visualization."
-$nl
-"Bare gadgets can be constructed directly, which is useful if all you need is a custom appearance with no further behavior (see " { $link "ui-pen-protocol" } "):"
-{ $subsection <gadget> }
-"New gadgets are defined as subclasses of an existing gadget type, perhaps even " { $link gadget } " itself. A parametrized constructor should be used to construct subclasses:"
-{ $subsection new-gadget }
-"Further topics:"
-{ $subsection "ui-gestures" }
-{ $subsection "ui-paint" }
-{ $subsection "ui-control-impl" }
-{ $subsection "clipboard-protocol" }
-{ $see-also "ui-layout-impl" } ;
-
-ARTICLE: "ui" "UI framework"
-{ $subsection "ui-glossary" }
-{ $subsection "building-ui" }
-{ $subsection "new-gadgets" }
-{ $subsection "ui-backend" } ;
-
-ABOUT: "ui"
+++ /dev/null
-! Copyright (C) 2006, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs io kernel math models namespaces
-prettyprint dlists dequeues sequences threads sequences words
-debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
-ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.flags sets accessors ;
-IN: ui
-
-! Assoc mapping aliens to gadgets
-SYMBOL: windows
-
-SYMBOL: stop-after-last-window?
-
-: event-loop? ( -- ? )
- {
- { [ stop-after-last-window? get not ] [ t ] }
- { [ graft-queue dequeue-empty? not ] [ t ] }
- { [ windows get-global empty? not ] [ t ] }
- [ f ]
- } cond ;
-
-: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
-
-: window ( handle -- world ) windows get-global at ;
-
-: window-focus ( handle -- gadget ) window world-focus ;
-
-: register-window ( world handle -- )
- #! Add the new window just below the topmost window. Why?
- #! So that if the new window doesn't actually receive focus
- #! (eg, we're using focus follows mouse and the mouse is not
- #! in the new window when it appears) Factor doesn't get
- #! confused and send workspace operations to the new window,
- #! etc.
- swap 2array windows get-global push
- windows get-global dup length 1 >
- [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
-
-: unregister-window ( handle -- )
- windows global [ [ first = not ] with filter ] change-at ;
-
-: raised-window ( world -- )
- windows get-global
- [ [ second eq? ] with find drop ] keep
- [ nth ] [ delete-nth ] [ nip ] 2tri push ;
-
-: focus-gestures ( new old -- )
- drop-prefix <reversed>
- T{ lose-focus } swap each-gesture
- T{ gain-focus } swap each-gesture ;
-
-: focus-world ( world -- )
- t over set-world-focused?
- dup raised-window
- focus-path f focus-gestures ;
-
-: unfocus-world ( world -- )
- f over set-world-focused?
- focus-path f swap focus-gestures ;
-
-M: world graft*
- dup (open-window)
- dup world-title over set-title
- request-focus ;
-
-: reset-world ( world -- )
- #! This is used when a window is being closed, but also
- #! when restoring saved worlds on image startup.
- dup world-fonts clear-assoc
- dup unfocus-world
- f swap set-world-handle ;
-
-M: world ungraft*
- dup free-fonts
- dup hand-clicked close-global
- dup hand-gadget close-global
- dup world-handle (close-window)
- reset-world ;
-
-: find-window ( quot -- 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
- V{ } clone windows set-global ;
-
-: restore-gadget-later ( gadget -- )
- dup gadget-graft-state {
- { { f f } [ ] }
- { { f t } [ ] }
- { { t t } [
- { f f } over set-gadget-graft-state
- ] }
- { { t f } [
- dup unqueue-graft
- { f f } over set-gadget-graft-state
- ] }
- } case graft-later ;
-
-: restore-gadget ( gadget -- )
- dup restore-gadget-later
- gadget-children [ restore-gadget ] each ;
-
-: 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 ;
-
-: layout-queued ( -- seq )
- [
- in-layout? on
- layout-queue [
- dup layout find-world [ , ] when*
- ] slurp-dequeue
- ] { } make prune ;
-
-: redraw-worlds ( seq -- )
- [ dup update-hand draw-world ] each ;
-
-: notify ( gadget -- )
- dup gadget-graft-state
- dup first { f f } { t t } ?
- pick set-gadget-graft-state {
- { { f t } [ dup activate-control graft* ] }
- { { t f } [ dup deactivate-control ungraft* ] }
- } case ;
-
-: notify-queued ( -- )
- graft-queue [ notify ] slurp-dequeue ;
-
-: update-ui ( -- )
- [ notify-queued layout-queued redraw-worlds ] assert-depth ;
-
-: ui-wait ( -- )
- 10 sleep ;
-
-: ui-try ( quot -- ) [ ui-error ] recover ;
-
-SYMBOL: ui-thread
-
-: ui-running ( quot -- )
- t \ ui-running set-global
- [ f \ ui-running set-global ] [ ] cleanup ; inline
-
-: ui-running? ( -- ? )
- \ ui-running get-global ;
-
-: update-ui-loop ( -- )
- ui-running? ui-thread get-global self eq? and [
- ui-notify-flag get lower-flag
- [ update-ui ] ui-try
- update-ui-loop
- ] when ;
-
-: start-ui-thread ( -- )
- [ self ui-thread set-global update-ui-loop ]
- "UI update" spawn drop ;
-
-: open-world-window ( world -- )
- dup pref-dim over (>>dim) dup relayout graft ;
-
-: open-window ( gadget title -- )
- f <world> open-world-window ;
-
-: set-fullscreen? ( ? gadget -- )
- find-world set-fullscreen* ;
-
-: fullscreen? ( gadget -- ? )
- find-world fullscreen* ;
-
-: raise-window ( gadget -- )
- find-world raise-window* ;
-
-HOOK: close-window ui-backend ( gadget -- )
-
-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 ;
-
-[
- f \ ui-running set-global
- <flag> ui-notify-flag set-global
-] "ui" add-init-hook
-
-HOOK: ui ui-backend ( -- )
-
-MAIN: ui
-
-: with-ui ( quot -- )
- ui-running? [
- call
- ] [
- f windows set-global
- [
- ui-hook set
- stop-after-last-window? on
- ui
- ] with-scope
- ] if ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2005, 2006 Doug Coleman.
-! Portions copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui
-ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
-ui.gestures io kernel math math.vectors namespaces
-sequences strings vectors words windows.kernel32 windows.gdi32
-windows.user32 windows.opengl32 windows.messages windows.types
-windows.nt windows threads libc combinators continuations
-command-line shuffle opengl ui.render unicode.case ascii
-math.bitfields locals symbols accessors math.geometry.rect ;
-IN: ui.windows
-
-SINGLETON: windows-ui-backend
-
-: crlf>lf ( str -- str' )
- CHAR: \r swap remove ;
-
-: lf>crlf ( str -- str' )
- [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
-
-: enum-clipboard ( -- seq )
- 0
- [ EnumClipboardFormats win32-error dup dup 0 > ]
- [ ]
- [ drop ]
- produce nip ;
-
-: with-clipboard ( quot -- )
- f OpenClipboard win32-error=0/f
- call
- CloseClipboard win32-error=0/f ; inline
-
-: paste ( -- str )
- [
- CF_UNICODETEXT IsClipboardFormatAvailable zero? [
- ! nothing to paste
- ""
- ] [
- CF_UNICODETEXT GetClipboardData dup win32-error=0/f
- dup GlobalLock dup win32-error=0/f
- GlobalUnlock win32-error=0/f
- utf16n alien>string
- ] if
- ] with-clipboard
- crlf>lf ;
-
-: copy ( str -- )
- lf>crlf [
- utf16n string>alien
- EmptyClipboard win32-error=0/f
- GMEM_MOVEABLE over length 1+ GlobalAlloc
- dup win32-error=0/f
-
- dup GlobalLock dup win32-error=0/f
- swapd byte-array>memory
- dup GlobalUnlock win32-error=0/f
- CF_UNICODETEXT swap SetClipboardData win32-error=0/f
- ] with-clipboard ;
-
-TUPLE: pasteboard ;
-C: <pasteboard> pasteboard
-
-M: pasteboard clipboard-contents drop paste ;
-M: pasteboard set-clipboard-contents drop copy ;
-
-: init-clipboard ( -- )
- <pasteboard> clipboard set-global
- <clipboard> selection set-global ;
-
-! world-handle is a <win>
-TUPLE: win hWnd hDC hRC world title ;
-C: <win> win
-
-SYMBOLS: msg-obj class-name-ptr mouse-captured ;
-
-: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
-: ex-style ( -- n ) WS_EX_APPWINDOW WS_EX_WINDOWEDGE bitor ; inline
-
-: get-RECT-top-left ( RECT -- x y )
- [ RECT-left ] keep RECT-top ;
-
-: get-RECT-dimensions ( RECT -- x y width height )
- [ get-RECT-top-left ] keep
- [ RECT-right ] keep [ RECT-left - ] keep
- [ RECT-bottom ] keep RECT-top - ;
-
-: handle-wm-paint ( hWnd uMsg wParam lParam -- )
- #! wParam and lParam are unused
- #! only paint if width/height both > 0
- 3drop window relayout-1 yield ;
-
-: handle-wm-size ( hWnd uMsg wParam lParam -- )
- 2nip
- [ lo-word ] keep hi-word 2array
- dup { 0 0 } = [ 2drop ] [ swap window (>>dim) ] if ;
-
-: handle-wm-move ( hWnd uMsg wParam lParam -- )
- 2nip
- [ lo-word ] keep hi-word 2array
- swap window (>>window-loc) ;
-
-: wm-keydown-codes ( -- key )
- H{
- { 8 "BACKSPACE" }
- { 9 "TAB" }
- { 13 "RET" }
- { 27 "ESC" }
- { 33 "PAGE_UP" }
- { 34 "PAGE_DOWN" }
- { 35 "END" }
- { 36 "HOME" }
- { 37 "LEFT" }
- { 38 "UP" }
- { 39 "RIGHT" }
- { 40 "DOWN" }
- { 45 "INSERT" }
- { 46 "DELETE" }
- { 112 "F1" }
- { 113 "F2" }
- { 114 "F3" }
- { 115 "F4" }
- { 116 "F5" }
- { 117 "F6" }
- { 118 "F7" }
- { 119 "F8" }
- { 120 "F9" }
- { 121 "F10" }
- { 122 "F11" }
- { 123 "F12" }
- } ;
-
-: key-state-down? ( key -- ? )
- GetKeyState 16 bit? ;
-
-: left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
-: left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
-: left-alt? ( -- ? ) VK_LMENU key-state-down? ;
-: right-shift? ( -- ? ) VK_RSHIFT key-state-down? ;
-: right-ctrl? ( -- ? ) VK_RCONTROL key-state-down? ;
-: right-alt? ( -- ? ) VK_RMENU key-state-down? ;
-: shift? ( -- ? ) left-shift? right-shift? or ;
-: ctrl? ( -- ? ) left-ctrl? right-ctrl? or ;
-: alt? ( -- ? ) left-alt? right-alt? or ;
-: caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ;
-
-: switch-case ( seq -- seq )
- dup first CHAR: a >= [ >upper ] [ >lower ] if ;
-
-: switch-case? ( -- ? ) shift? caps-lock? xor not ;
-
-: key-modifiers ( -- seq )
- [
- shift? [ S+ , ] when
- ctrl? [ C+ , ] when
- alt? [ A+ , ] when
- ] { } make [ empty? not ] keep f ? ;
-
-: exclude-keys-wm-keydown
- H{
- { 16 "SHIFT" }
- { 17 "CTRL" }
- { 18 "ALT" }
- { 20 "CAPS-LOCK" }
- } ;
-
-: exclude-keys-wm-char
- ! Values are ignored
- H{
- { 8 "BACKSPACE" }
- { 9 "TAB" }
- { 13 "RET" }
- { 27 "ESC" }
- } ;
-
-: exclude-key-wm-keydown? ( n -- bool )
- exclude-keys-wm-keydown key? ;
-
-: exclude-key-wm-char? ( n -- bool )
- exclude-keys-wm-char key? ;
-
-: keystroke>gesture ( n -- mods sym ? )
- dup wm-keydown-codes at* [
- nip >r key-modifiers r> t
- ] [
- drop 1string >r key-modifiers r>
- C+ pick member? >r A+ pick member? r> or [
- shift? [ >lower ] unless f
- ] [
- switch-case? [ switch-case ] when t
- ] if
- ] if ;
-
-:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
- wParam exclude-key-wm-keydown? [
- wParam keystroke>gesture <key-down>
- hWnd window-focus send-gesture drop
- ] unless ;
-
-:: handle-wm-char ( hWnd uMsg wParam lParam -- )
- wParam exclude-key-wm-char? ctrl? alt? xor or [
- wParam 1string
- hWnd window-focus user-input
- ] unless ;
-
-:: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
- wParam keystroke>gesture <key-up>
- hWnd window-focus send-gesture drop ;
-
-:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
- ? hwnd window set-world-active?
- hwnd uMsg wParam lParam DefWindowProc ;
-
-: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
- {
- { [ over SC_MINIMIZE = ] [ f set-window-active ] }
- { [ over SC_RESTORE = ] [ t set-window-active ] }
- { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
- { [ dup alpha? ] [ 4drop 0 ] }
- { [ t ] [ DefWindowProc ] }
- } cond ;
-
-: cleanup-window ( handle -- )
- dup win-title [ free ] when*
- dup win-hRC wglDeleteContext win32-error=0/f
- dup win-hWnd swap win-hDC ReleaseDC win32-error=0/f ;
-
-M: windows-ui-backend (close-window)
- dup win-hWnd unregister-window
- dup cleanup-window
- win-hWnd DestroyWindow win32-error=0/f ;
-
-: handle-wm-close ( hWnd uMsg wParam lParam -- )
- 3drop window ungraft ;
-
-: handle-wm-set-focus ( hWnd uMsg wParam lParam -- )
- 3drop window [ focus-world ] when* ;
-
-: handle-wm-kill-focus ( hWnd uMsg wParam lParam -- )
- 3drop window [ unfocus-world ] when* ;
-
-: message>button ( uMsg -- button down? )
- {
- { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] }
- { [ dup WM_LBUTTONUP = ] [ drop 1 f ] }
- { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] }
- { [ dup WM_MBUTTONUP = ] [ drop 2 f ] }
- { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] }
- { [ dup WM_RBUTTONUP = ] [ drop 3 f ] }
-
- { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] }
- { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] }
- { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] }
- { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] }
- { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] }
- { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] }
- } cond ;
-
-! If the user clicks in the window border ("non-client area")
-! Windows sends us an NC[LMR]BUTTONDOWN message; but if the
-! mouse is subsequently released outside the NC area, we receive
-! a [LMR]BUTTONUP message and Factor can get confused. So we
-! ignore BUTTONUP's that are a result of an NC*BUTTONDOWN.
-SYMBOL: nc-buttons
-
-: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
- 2drop nip
- message>button nc-buttons get
- swap [ push ] [ delete ] if ;
-
-: >lo-hi ( WORD -- array ) [ lo-word ] keep hi-word 2array ;
-: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
-
-: mouse-absolute>relative ( lparam handle -- array )
- >r >lo-hi r>
- "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
- get-RECT-top-left 2array v- ;
-
-: mouse-event>gesture ( uMsg -- button )
- key-modifiers swap message>button
- [ <button-down> ] [ <button-up> ] if ;
-
-: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
- nip >r mouse-event>gesture r> >lo-hi rot window ;
-
-: set-capture ( hwnd -- )
- mouse-captured get [
- drop
- ] [
- [ SetCapture drop ] keep
- mouse-captured set
- ] if ;
-
-: release-capture ( -- )
- ReleaseCapture win32-error=0/f
- mouse-captured off ;
-
-: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
- >r >r
- over set-capture
- dup message>button drop nc-buttons get delete
- r> r> prepare-mouse send-button-down ;
-
-: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
- mouse-captured get [ release-capture ] when
- pick message>button drop dup nc-buttons get member? [
- nc-buttons get delete 4drop
- ] [
- drop prepare-mouse send-button-up
- ] if ;
-
-: make-TRACKMOUSEEVENT ( hWnd -- alien )
- "TRACKMOUSEEVENT" <c-object> [ set-TRACKMOUSEEVENT-hwndTrack ] keep
- "TRACKMOUSEEVENT" heap-size over set-TRACKMOUSEEVENT-cbSize ;
-
-: handle-wm-mousemove ( hWnd uMsg wParam lParam -- )
- 2nip
- over make-TRACKMOUSEEVENT
- TME_LEAVE over set-TRACKMOUSEEVENT-dwFlags
- 0 over set-TRACKMOUSEEVENT-dwHoverTime
- TrackMouseEvent drop
- >lo-hi swap window move-hand fire-motion ;
-
-: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
- >r nip r>
- pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
-
-: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
- #! message sent if windows needs application to stop dragging
- 4drop release-capture ;
-
-: handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
- #! message sent if mouse leaves main application
- 4drop forget-rollover ;
-
-SYMBOL: wm-handlers
-
-H{ } clone wm-handlers set-global
-
-: add-wm-handler ( quot wm -- )
- dup array?
- [ [ execute add-wm-handler ] with each ]
- [ wm-handlers get-global set-at ] if ;
-
-[ handle-wm-close 0 ] WM_CLOSE add-wm-handler
-[ 4dup handle-wm-paint DefWindowProc ] WM_PAINT add-wm-handler
-
-[ handle-wm-size 0 ] WM_SIZE add-wm-handler
-[ handle-wm-move 0 ] WM_MOVE add-wm-handler
-
-[ 4dup handle-wm-keydown DefWindowProc ] { WM_KEYDOWN WM_SYSKEYDOWN } add-wm-handler
-[ 4dup handle-wm-char DefWindowProc ] { WM_CHAR WM_SYSCHAR } add-wm-handler
-[ 4dup handle-wm-keyup DefWindowProc ] { WM_KEYUP WM_SYSKEYUP } add-wm-handler
-
-[ handle-wm-syscommand ] WM_SYSCOMMAND add-wm-handler
-[ handle-wm-set-focus 0 ] WM_SETFOCUS add-wm-handler
-[ handle-wm-kill-focus 0 ] WM_KILLFOCUS add-wm-handler
-
-[ handle-wm-buttondown 0 ] WM_LBUTTONDOWN add-wm-handler
-[ handle-wm-buttondown 0 ] WM_MBUTTONDOWN add-wm-handler
-[ handle-wm-buttondown 0 ] WM_RBUTTONDOWN add-wm-handler
-[ handle-wm-buttonup 0 ] WM_LBUTTONUP add-wm-handler
-[ handle-wm-buttonup 0 ] WM_MBUTTONUP add-wm-handler
-[ handle-wm-buttonup 0 ] WM_RBUTTONUP add-wm-handler
-
-[ 4dup handle-wm-ncbutton DefWindowProc ]
-{ WM_NCLBUTTONDOWN WM_NCMBUTTONDOWN WM_NCRBUTTONDOWN
-WM_NCLBUTTONUP WM_NCMBUTTONUP WM_NCRBUTTONUP }
-add-wm-handler
-
-[ nc-buttons get-global delete-all DefWindowProc ]
-{ WM_EXITSIZEMOVE WM_EXITMENULOOP } add-wm-handler
-
-[ handle-wm-mousemove 0 ] WM_MOUSEMOVE add-wm-handler
-[ handle-wm-mousewheel 0 ] WM_MOUSEWHEEL add-wm-handler
-[ handle-wm-cancelmode 0 ] WM_CANCELMODE add-wm-handler
-[ handle-wm-mouseleave 0 ] WM_MOUSELEAVE add-wm-handler
-
-SYMBOL: trace-messages?
-
-! return 0 if you handle the message, else just let DefWindowProc return its val
-: ui-wndproc ( -- object )
- "uint" { "void*" "uint" "long" "long" } "stdcall" [
- [
- pick
- trace-messages? get-global [ dup windows-message-name name>> print flush ] when
- wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
- ] ui-try
- ] alien-callback ;
-
-: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
-
-M: windows-ui-backend do-events
- msg-obj get-global
- dup peek-message? [ drop ui-wait ] [
- [ TranslateMessage drop ]
- [ DispatchMessage drop ] bi
- ] if ;
-
-: register-wndclassex ( -- class )
- "WNDCLASSEX" <c-object>
- f GetModuleHandle
- class-name-ptr get-global
- pick GetClassInfoEx zero? [
- "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
- { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
- ui-wndproc over set-WNDCLASSEX-lpfnWndProc
- 0 over set-WNDCLASSEX-cbClsExtra
- 0 over set-WNDCLASSEX-cbWndExtra
- f GetModuleHandle over set-WNDCLASSEX-hInstance
- f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
- over set-WNDCLASSEX-hIcon
- f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
-
- class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
- RegisterClassEx dup win32-error=0/f
- ] when ;
-
-: adjust-RECT ( RECT -- )
- style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
-
-: make-RECT ( world -- RECT )
- dup window-loc>> { 40 40 } vmax dup rot rect-dim v+
- "RECT" <c-object>
- over first over set-RECT-right
- swap second over set-RECT-bottom
- over first over set-RECT-left
- swap second over set-RECT-top ;
-
-: make-adjusted-RECT ( rect -- RECT )
- make-RECT dup adjust-RECT ;
-
-: create-window ( rect -- hwnd )
- make-adjusted-RECT
- >r class-name-ptr get-global f r>
- >r >r >r ex-style r> r>
- { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
- r> get-RECT-dimensions
- f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
-
-: show-window ( hWnd -- )
- dup SW_SHOW ShowWindow drop ! always succeeds
- dup SetForegroundWindow drop
- SetFocus drop ;
-
-: init-win32-ui ( -- )
- V{ } clone nc-buttons set-global
- "MSG" malloc-object msg-obj set-global
- "Factor-window" utf16n malloc-string class-name-ptr set-global
- register-wndclassex drop
- GetDoubleClickTime double-click-timeout set-global ;
-
-: cleanup-win32-ui ( -- )
- class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
- msg-obj get-global [ free ] when*
- f class-name-ptr set-global
- f msg-obj set-global ;
-
-: setup-pixel-format ( hdc -- )
- 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
- swapd SetPixelFormat win32-error=0/f ;
-
-: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
-
-: get-rc ( hDC -- hRC )
- dup wglCreateContext dup win32-error=0/f
- [ wglMakeCurrent win32-error=0/f ] keep ;
-
-: setup-gl ( hwnd -- hDC hRC )
- get-dc dup setup-pixel-format dup get-rc ;
-
-M: windows-ui-backend (open-window) ( world -- )
- [ create-window dup setup-gl ] keep
- [ f <win> ] keep
- [ swap win-hWnd register-window ] 2keep
- dupd set-world-handle
- win-hWnd show-window ;
-
-M: windows-ui-backend select-gl-context ( handle -- )
- [ win-hDC ] keep win-hRC wglMakeCurrent win32-error=0/f ;
-
-M: windows-ui-backend flush-gl-context ( handle -- )
- win-hDC SwapBuffers win32-error=0/f ;
-
-! Move window to front
-M: windows-ui-backend raise-window* ( world -- )
- world-handle [
- win-hWnd SetFocus drop
- ] when* ;
-
-M: windows-ui-backend set-title ( string world -- )
- world-handle
- dup win-title [ free ] when*
- >r utf16n malloc-string r>
- 2dup set-win-title
- win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;
-
-M: windows-ui-backend ui
- [
- [
- stop-after-last-window? on
- init-clipboard
- init-win32-ui
- start-ui
- event-loop
- ] [ cleanup-win32-ui ] [ ] cleanup
- ] ui-running ;
-
-M: windows-ui-backend beep ( -- )
- 0 MessageBeep drop ;
-
-windows-ui-backend ui-backend set-global
-
-[ "ui" ] main-vocab-hook set-global
+++ /dev/null
-Slava Pestov
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays ui ui.gadgets
-ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
-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 debugger command-line qualified
-math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
-QUALIFIED: system
-IN: ui.x11
-
-SINGLETON: x11-ui-backend
-
-: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
-
-TUPLE: x11-handle window glx xic ;
-
-C: <x11-handle> x11-handle
-
-M: world expose-event nip relayout ;
-
-M: world configure-event
- over configured-loc over (>>window-loc)
- swap configured-dim over (>>dim)
- ! In case dimensions didn't change
- relayout-1 ;
-
-: modifiers
- {
- { S+ HEX: 1 }
- { C+ HEX: 4 }
- { A+ HEX: 8 }
- } ;
-
-: key-codes
- H{
- { HEX: FF08 "BACKSPACE" }
- { HEX: FF09 "TAB" }
- { HEX: FF0D "RET" }
- { HEX: FF8D "ENTER" }
- { HEX: FF1B "ESC" }
- { HEX: FFFF "DELETE" }
- { HEX: FF50 "HOME" }
- { HEX: FF51 "LEFT" }
- { HEX: FF52 "UP" }
- { HEX: FF53 "RIGHT" }
- { HEX: FF54 "DOWN" }
- { HEX: FF55 "PAGE_UP" }
- { HEX: FF56 "PAGE_DOWN" }
- { HEX: FF57 "END" }
- { HEX: FF58 "BEGIN" }
- { HEX: FFBE "F1" }
- { HEX: FFBF "F2" }
- { HEX: FFC0 "F3" }
- { HEX: FFC1 "F4" }
- { HEX: FFC2 "F5" }
- { HEX: FFC3 "F6" }
- { HEX: FFC4 "F7" }
- { HEX: FFC5 "F8" }
- { HEX: FFC6 "F9" }
- } ;
-
-: key-code ( keysym -- keycode action? )
- dup key-codes at [ t ] [ 1string f ] ?if ;
-
-: event-modifiers ( event -- seq )
- XKeyEvent-state modifiers modifier ;
-
-: key-down-event>gesture ( event world -- string gesture )
- dupd
- world-handle x11-handle-xic lookup-string
- >r swap event-modifiers r> key-code <key-down> ;
-
-M: world key-down-event
- [ key-down-event>gesture ] keep world-focus
- [ send-gesture ] keep swap [ user-input ] [ 2drop ] if ;
-
-: key-up-event>gesture ( event -- gesture )
- dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
-
-M: world key-up-event
- >r key-up-event>gesture r> world-focus send-gesture drop ;
-
-: mouse-event>gesture ( event -- modifiers button loc )
- dup event-modifiers over XButtonEvent-button
- rot mouse-event-loc ;
-
-M: world button-down-event
- >r mouse-event>gesture >r <button-down> r> r>
- send-button-down ;
-
-M: world button-up-event
- >r mouse-event>gesture >r <button-up> r> r>
- send-button-up ;
-
-: mouse-event>scroll-direction ( event -- pair )
- XButtonEvent-button {
- { 4 { 0 -1 } }
- { 5 { 0 1 } }
- { 6 { -1 0 } }
- { 7 { 1 0 } }
- } at ;
-
-M: world wheel-event
- >r dup mouse-event>scroll-direction swap mouse-event-loc r>
- send-wheel ;
-
-M: world enter-event motion-event ;
-
-M: world leave-event 2drop forget-rollover ;
-
-M: world motion-event
- >r dup XMotionEvent-x swap XMotionEvent-y 2array r>
- move-hand fire-motion ;
-
-M: world focus-in-event
- nip
- dup world-handle x11-handle-xic XSetICFocus focus-world ;
-
-M: world focus-out-event
- nip
- dup world-handle x11-handle-xic XUnsetICFocus unfocus-world ;
-
-M: world selection-notify-event
- [ world-handle x11-handle-window selection-from-event ] keep
- world-focus user-input ;
-
-: supported-type? ( atom -- ? )
- { "UTF8_STRING" "STRING" "TEXT" }
- [ x-atom = ] with contains? ;
-
-: clipboard-for-atom ( atom -- clipboard )
- {
- { [ dup XA_PRIMARY = ] [ drop selection get ] }
- { [ dup XA_CLIPBOARD = ] [ drop clipboard get ] }
- [ drop <clipboard> ]
- } cond ;
-
-: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target
- XA_UTF8_STRING = utf8 ascii ? encode ;
-
-: set-selection-prop ( evt -- )
- dpy get swap
- [ XSelectionRequestEvent-requestor ] keep
- [ XSelectionRequestEvent-property ] keep
- [ XSelectionRequestEvent-target ] keep
- >r 8 PropModeReplace r>
- [
- XSelectionRequestEvent-selection
- clipboard-for-atom x-clipboard-contents
- ] keep encode-clipboard dup length XChangeProperty drop ;
-
-M: world selection-request-event
- drop dup XSelectionRequestEvent-target {
- { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
- { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
- { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
- [ drop send-notify-failure ]
- } cond ;
-
-M: x11-ui-backend (close-window) ( handle -- )
- dup x11-handle-xic XDestroyIC
- dup x11-handle-glx destroy-glx
- x11-handle-window dup unregister-window
- destroy-window ;
-
-M: world client-event
- swap close-box? [ ungraft ] [ drop ] if ;
-
-: gadget-window ( world -- )
- dup window-loc>> over rect-dim glx-window
- over "Factor" create-xic <x11-handle>
- 2dup x11-handle-window register-window
- swap set-world-handle ;
-
-: wait-event ( -- event )
- QueuedAfterFlush events-queued 0 > [
- next-event dup
- None XFilterEvent zero? [ drop wait-event ] unless
- ] [
- ui-wait wait-event
- ] if ;
-
-M: x11-ui-backend do-events
- wait-event dup XAnyEvent-window window dup
- [ [ 2dup handle-event ] assert-depth ] when 2drop ;
-
-: x-clipboard@ ( gadget clipboard -- prop win )
- x-clipboard-atom swap
- find-world world-handle x11-handle-window ;
-
-M: x-clipboard copy-clipboard
- [ x-clipboard@ own-selection ] keep
- set-x-clipboard-contents ;
-
-M: x-clipboard paste-clipboard
- >r find-world world-handle x11-handle-window
- r> x-clipboard-atom convert-selection ;
-
-: init-clipboard ( -- )
- XA_PRIMARY <x-clipboard> selection set-global
- XA_CLIPBOARD <x-clipboard> clipboard set-global ;
-
-: set-title-old ( dpy window string -- )
- dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
-
-: set-title-new ( dpy window string -- )
- >r
- XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
- r> utf8 encode dup length XChangeProperty drop ;
-
-M: x11-ui-backend set-title ( string world -- )
- world-handle x11-handle-window swap dpy get -rot
- 3dup set-title-old set-title-new ;
-
-M: x11-ui-backend set-fullscreen* ( ? world -- )
- world-handle x11-handle-window "XClientMessageEvent" <c-object>
- tuck set-XClientMessageEvent-window
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
- over set-XClientMessageEvent-data0
- ClientMessage over set-XClientMessageEvent-type
- dpy get over set-XClientMessageEvent-display
- "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
- 32 over set-XClientMessageEvent-format
- "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
- >r dpy get root get 0 SubstructureNotifyMask r> XSendEvent drop ;
-
-
-M: x11-ui-backend (open-window) ( world -- )
- dup gadget-window
- world-handle x11-handle-window dup set-closable map-window ;
-
-M: x11-ui-backend raise-window* ( world -- )
- world-handle [
- dpy get swap x11-handle-window XRaiseWindow drop
- ] when* ;
-
-M: x11-ui-backend select-gl-context ( handle -- )
- dpy get swap
- dup x11-handle-window swap x11-handle-glx glXMakeCurrent
- [ "Failed to set current GLX context" throw ] unless ;
-
-M: x11-ui-backend flush-gl-context ( handle -- )
- dpy get swap x11-handle-window glXSwapBuffers ;
-
-M: x11-ui-backend ui ( -- )
- [
- f [
- [
- stop-after-last-window? on
- init-clipboard
- start-ui
- event-loop
- ] with-xim
- ] with-x
- ] ui-running ;
-
-M: x11-ui-backend beep ( -- )
- dpy get 100 XBell drop ;
-
-x11-ui-backend ui-backend set-global
-
-[ "DISPLAY" system:os-env "ui" "listener" ? ]
-main-vocab-hook set-global
projects / factor.git / commitdiff