Merge branch 'master' of git://factorcode.org/git/factor
commit
dc9ddd3af6
|
@ -21,8 +21,6 @@ HOOK: (close-offscreen-buffer) ui-backend ( handle -- )
|
|||
|
||||
HOOK: raise-window* ui-backend ( world -- )
|
||||
|
||||
HOOK: system-background-color ui-backend ( -- color )
|
||||
|
||||
GENERIC: select-gl-context ( handle -- )
|
||||
|
||||
GENERIC: flush-gl-context ( handle -- )
|
||||
|
|
|
@ -7,7 +7,7 @@ cocoa.views cocoa.windows combinators command-line
|
|||
core-foundation core-foundation.run-loop core-graphics
|
||||
core-graphics.types destructors fry generalizations io.thread
|
||||
kernel libc literals locals math math.bitwise math.rectangles memory
|
||||
namespaces sequences threads ui
|
||||
namespaces sequences threads ui colors
|
||||
ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
|
||||
ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
|
||||
ui.private words.symbol ;
|
||||
|
@ -58,9 +58,6 @@ M: cocoa-ui-backend (pixel-format-attribute)
|
|||
[ first 0 <int> [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ]
|
||||
if-empty ;
|
||||
|
||||
M: cocoa-ui-backend system-background-color
|
||||
T{ rgba f 0.0 0.0 0.0 0.0 } ; inline
|
||||
|
||||
TUPLE: pasteboard handle ;
|
||||
|
||||
C: <pasteboard> pasteboard
|
||||
|
@ -133,7 +130,8 @@ CONSTANT: window-control>styleMask
|
|||
M:: cocoa-ui-backend (open-window) ( world -- )
|
||||
world [ [ dim>> ] dip <FactorView> ]
|
||||
with-world-pixel-format :> view
|
||||
world transparent?>> [ view make-context-transparent ] when
|
||||
world window-controls>> textured-background swap memq?
|
||||
[ view make-context-transparent ] when
|
||||
view world [ world>NSRect ] [ world>styleMask ] bi <ViewWindow> :> window
|
||||
view -> release
|
||||
world view register-window
|
||||
|
|
|
@ -401,7 +401,7 @@ CLASS: {
|
|||
|
||||
{ "isOpaque" "char" { "id" "SEL" }
|
||||
[
|
||||
drop window transparent?>> not >c-bool
|
||||
2drop 0
|
||||
]
|
||||
}
|
||||
|
||||
|
|
|
@ -165,11 +165,6 @@ M: windows-ui-backend (pixel-format-attribute)
|
|||
over world>> has-wglChoosePixelFormatARB?
|
||||
[ arb-pixel-format-attribute ] [ pfd-pixel-format-attribute ] if ;
|
||||
|
||||
M: windows-ui-backend system-background-color
|
||||
composition-enabled?
|
||||
[ T{ rgba f 0.0 0.0 0.0 0.0 } ]
|
||||
[ COLOR_BTNFACE GetSysColor RGB>color ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: lo-word ( wparam -- lo ) <short> *short ; inline
|
||||
|
@ -538,10 +533,17 @@ SYMBOL: nc-buttons
|
|||
#! message sent if mouse leaves main application
|
||||
4drop forget-rollover ;
|
||||
|
||||
: system-background-color ( -- color )
|
||||
COLOR_BTNFACE GetSysColor RGB>color ;
|
||||
|
||||
: ?make-glass ( world hwnd -- )
|
||||
swap { [ transparent?>> ] [ drop windows-major 6 >= ] } 1&&
|
||||
[ full-window-margins DwmExtendFrameIntoClientArea drop ]
|
||||
[ drop ] if ;
|
||||
over window-controls>> textured-background swap memq? [
|
||||
composition-enabled? [
|
||||
full-window-margins DwmExtendFrameIntoClientArea drop
|
||||
T{ rgba f 0.0 0.0 0.0 0.0 }
|
||||
] [ drop system-background-color ] if >>background-color
|
||||
drop
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: handle-wm-dwmcompositionchanged ( hWnd uMsg wParam lParam -- )
|
||||
3drop [ window ] keep ?make-glass ;
|
||||
|
|
|
@ -63,9 +63,6 @@ M: x11-ui-backend (pixel-format-attribute)
|
|||
0 <int> [ glXGetConfig drop ] keep *int
|
||||
] if-empty ;
|
||||
|
||||
M: x11-ui-backend system-background-color
|
||||
T{ rgba f 0.0 0.0 0.0 0.0 } ; inline
|
||||
|
||||
CONSTANT: modifiers
|
||||
{
|
||||
{ S+ HEX: 1 }
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs continuations kernel math models
|
||||
namespaces opengl opengl.textures sequences io combinators
|
||||
namespaces opengl opengl.textures sequences io colors combinators
|
||||
combinators.short-circuit fry math.vectors math.rectangles cache
|
||||
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
|
||||
ui.pixel-formats destructors literals strings ;
|
||||
|
@ -17,7 +17,11 @@ SYMBOLS:
|
|||
textured-background ;
|
||||
|
||||
CONSTANT: default-world-pixel-format-attributes
|
||||
{ windowed double-buffered T{ depth-bits { value 16 } } }
|
||||
{
|
||||
windowed
|
||||
double-buffered
|
||||
T{ depth-bits { value 16 } }
|
||||
}
|
||||
|
||||
CONSTANT: default-world-window-controls
|
||||
{
|
||||
|
@ -35,7 +39,7 @@ TUPLE: world < track
|
|||
text-handle handle images
|
||||
window-loc
|
||||
pixel-format-attributes
|
||||
transparent?
|
||||
background-color
|
||||
window-controls
|
||||
window-resources ;
|
||||
|
||||
|
@ -115,13 +119,18 @@ M: world request-focus-on ( child gadget -- )
|
|||
f >>grab-input?
|
||||
V{ } clone >>window-resources ;
|
||||
|
||||
: initial-background-color ( attributes -- color )
|
||||
window-controls>> textured-background swap memq?
|
||||
[ T{ rgba f 0.0 0.0 0.0 0.0 } ]
|
||||
[ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
|
||||
|
||||
: apply-world-attributes ( world attributes -- world )
|
||||
{
|
||||
[ title>> >>title ]
|
||||
[ status>> >>status ]
|
||||
[ pixel-format-attributes>> >>pixel-format-attributes ]
|
||||
[ window-controls>> >>window-controls ]
|
||||
[ window-controls>> textured-background swap memq? >>transparent? ]
|
||||
[ initial-background-color >>background-color ]
|
||||
[ grab-input?>> >>grab-input? ]
|
||||
[ gadgets>> [ 1 track-add ] each ]
|
||||
} cleave ;
|
||||
|
@ -177,7 +186,6 @@ M: world draw-world*
|
|||
check-extensions
|
||||
{
|
||||
[ init-gl ]
|
||||
[ transparent?>> clear-gl ]
|
||||
[ draw-gadget ]
|
||||
[ text-handle>> [ purge-cache ] when* ]
|
||||
[ images>> [ purge-cache ] when* ]
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math.rectangles math.vectors namespaces kernel accessors
|
||||
assocs combinators sequences opengl opengl.gl colors
|
||||
colors.constants ui.backend ui.gadgets ui.pens ;
|
||||
colors.constants ui.gadgets ui.pens ;
|
||||
IN: ui.render
|
||||
|
||||
SYMBOL: clip
|
||||
|
@ -27,27 +27,20 @@ SYMBOL: viewport-translation
|
|||
[ clip set ] bi
|
||||
do-clip ;
|
||||
|
||||
: init-gl ( clip-rect -- )
|
||||
SLOT: background-color
|
||||
|
||||
: init-gl ( world -- )
|
||||
GL_SMOOTH glShadeModel
|
||||
GL_SCISSOR_TEST glEnable
|
||||
GL_BLEND glEnable
|
||||
GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
|
||||
GL_VERTEX_ARRAY glEnableClientState
|
||||
init-matrices
|
||||
init-clip ;
|
||||
|
||||
: clear-gl ( transparent? -- )
|
||||
[ init-clip ]
|
||||
[
|
||||
system-background-color
|
||||
[ red>> ] [ green>> ] [ blue>> ] tri 0.0
|
||||
glClearColor
|
||||
background-color>> >rgba-components glClearColor
|
||||
GL_COLOR_BUFFER_BIT glClear
|
||||
] [
|
||||
! white gl-clear is broken w.r.t window resizing
|
||||
! Linux/PPC Radeon 9200
|
||||
COLOR: white gl-color
|
||||
{ 0 0 } clip get dim>> gl-fill-rect
|
||||
] if ;
|
||||
] bi ;
|
||||
|
||||
GENERIC: draw-gadget* ( gadget -- )
|
||||
|
||||
|
|
|
@ -74,7 +74,7 @@ name>char-hook [
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: lexer-before ( i -- before )
|
||||
: lexer-subseq ( i -- before )
|
||||
[
|
||||
[
|
||||
lexer get
|
||||
|
@ -84,11 +84,6 @@ name>char-hook [
|
|||
lexer get (>>column)
|
||||
] bi ;
|
||||
|
||||
: find-next-token ( ch -- i elt )
|
||||
CHAR: \ 2array
|
||||
[ lexer get [ column>> ] [ line-text>> ] bi ] dip
|
||||
[ member? ] curry find-from ;
|
||||
|
||||
: rest-of-line ( lexer -- seq )
|
||||
[ line-text>> ] [ column>> ] bi tail-slice ;
|
||||
|
||||
|
@ -107,11 +102,7 @@ ERROR: escaped-char-expected ;
|
|||
escaped-char-expected
|
||||
] if ;
|
||||
|
||||
: next-line% ( lexer -- )
|
||||
[ rest-of-line % ]
|
||||
[ next-line "\n" % ] bi ;
|
||||
|
||||
: rest-begins? ( string -- ? )
|
||||
: lexer-head? ( string -- ? )
|
||||
[
|
||||
lexer get [ line-text>> ] [ column>> ] bi tail-slice
|
||||
] dip head? ;
|
||||
|
@ -119,6 +110,15 @@ ERROR: escaped-char-expected ;
|
|||
: advance-lexer ( n -- )
|
||||
[ lexer get ] dip [ + ] curry change-column drop ; inline
|
||||
|
||||
: find-next-token ( ch -- i elt )
|
||||
CHAR: \ 2array
|
||||
[ lexer get [ column>> ] [ line-text>> ] bi ] dip
|
||||
[ member? ] curry find-from ;
|
||||
|
||||
: next-line% ( lexer -- )
|
||||
[ rest-of-line % ]
|
||||
[ next-line "\n" % ] bi ;
|
||||
|
||||
: take-double-quotes ( -- string )
|
||||
lexer get dup current-char CHAR: " = [
|
||||
[ ] [ column>> ] [ line-text>> ] tri
|
||||
|
@ -138,29 +138,29 @@ ERROR: escaped-char-expected ;
|
|||
lexer get advance-char
|
||||
] if ;
|
||||
|
||||
DEFER: (parse-long-string)
|
||||
DEFER: (parse-multiline-string)
|
||||
|
||||
: parse-found-token ( i string token -- )
|
||||
[ lexer-before % ] dip
|
||||
[ lexer-subseq % ] dip
|
||||
CHAR: \ = [
|
||||
lexer get [ next-char , ] [ next-char , ] bi (parse-long-string)
|
||||
lexer get [ next-char , ] [ next-char , ] bi (parse-multiline-string)
|
||||
] [
|
||||
dup rest-begins? [
|
||||
dup lexer-head? [
|
||||
end-string-parse
|
||||
] [
|
||||
lexer get next-char , (parse-long-string)
|
||||
lexer get next-char , (parse-multiline-string)
|
||||
] if
|
||||
] if ;
|
||||
|
||||
ERROR: trailing-characters string ;
|
||||
|
||||
: (parse-long-string) ( string -- )
|
||||
: (parse-multiline-string) ( string -- )
|
||||
lexer get still-parsing? [
|
||||
dup first find-next-token [
|
||||
parse-found-token
|
||||
] [
|
||||
drop lexer get next-line%
|
||||
(parse-long-string)
|
||||
(parse-multiline-string)
|
||||
] if*
|
||||
] [
|
||||
unexpected-eof
|
||||
|
@ -168,13 +168,10 @@ ERROR: trailing-characters string ;
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: parse-long-string ( string -- string' )
|
||||
[ (parse-long-string) ] "" make ;
|
||||
|
||||
: parse-multiline-string ( -- string )
|
||||
lexer get rest-of-line "\"\"" head? [
|
||||
lexer get [ 2 + ] change-column drop
|
||||
"\"\"\""
|
||||
] [
|
||||
"\""
|
||||
] if parse-long-string unescape-string ;
|
||||
] if [ (parse-multiline-string) ] "" make unescape-string ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: decimals kernel locals math math.combinatorics math.ranges
|
||||
sequences ;
|
||||
IN: benchmark.e-decimals
|
||||
|
||||
:: calculate-e-decimals ( n -- e )
|
||||
n [1,b] [ factorial 0 <decimal> D: 1 swap n D/ ] map
|
||||
D: 1 [ D+ ] reduce ;
|
||||
|
||||
: calculate-e-decimals-benchmark ( -- )
|
||||
5 [ 800 calculate-e-decimals drop ] times ;
|
||||
|
||||
MAIN: calculate-e-decimals-benchmark
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1,12 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.combinatorics math.ranges sequences ;
|
||||
IN: benchmark.e-ratios
|
||||
|
||||
: calculate-e-ratios ( n -- e )
|
||||
iota [ factorial recip ] sigma ;
|
||||
|
||||
: calculate-e-ratios-benchmark ( -- )
|
||||
5 [ 300 calculate-e-ratios drop ] times ;
|
||||
|
||||
MAIN: calculate-e-ratios-benchmark
|
Loading…
Reference in New Issue