Merge git://factorcode.org/git/factor
Doug Coleman
commit
91db162a56
core/source-files
extra
calendar
catalyst-talk
lcd
tools/deploy
ui
|
|
@ -68,7 +68,7 @@ uses definitions ;
|
|||
: reset-checksums ( -- )
|
||||
source-files get [
|
||||
swap ?resource-path dup exists?
|
||||
[ file-lines record-checksum ] [ 2drop ] if
|
||||
[ file-lines swap record-checksum ] [ 2drop ] if
|
||||
] assoc-each ;
|
||||
|
||||
M: pathname where pathname-string 1 2array ;
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
Doug Coleman
|
||||
Slava Pestov
|
||||
|
|
|
|||
|
|
@ -333,16 +333,18 @@ M: integer year. ( n -- )
|
|||
M: timestamp year. ( timestamp -- )
|
||||
timestamp-year year. ;
|
||||
|
||||
: pad-00 number>string 2 CHAR: 0 pad-left write ;
|
||||
: pad-00 number>string 2 CHAR: 0 pad-left ;
|
||||
|
||||
: write-00 pad-00 write ;
|
||||
|
||||
: (timestamp>string) ( timestamp -- )
|
||||
dup day-of-week day-abbreviations3 nth write ", " write
|
||||
dup timestamp-day number>string write bl
|
||||
dup timestamp-month month-abbreviations nth write bl
|
||||
dup timestamp-year number>string write bl
|
||||
dup timestamp-hour pad-00 ":" write
|
||||
dup timestamp-minute pad-00 ":" write
|
||||
timestamp-second >fixnum pad-00 ;
|
||||
dup timestamp-hour write-00 ":" write
|
||||
dup timestamp-minute write-00 ":" write
|
||||
timestamp-second >fixnum write-00 ;
|
||||
|
||||
: timestamp>string ( timestamp -- str )
|
||||
[ (timestamp>string) ] string-out ;
|
||||
|
|
@ -357,11 +359,11 @@ M: timestamp year. ( timestamp -- )
|
|||
|
||||
: (timestamp>rfc3339) ( timestamp -- )
|
||||
dup timestamp-year number>string write CHAR: - write1
|
||||
dup timestamp-month pad-00 CHAR: - write1
|
||||
dup timestamp-day pad-00 CHAR: T write1
|
||||
dup timestamp-hour pad-00 CHAR: : write1
|
||||
dup timestamp-minute pad-00 CHAR: : write1
|
||||
timestamp-second >fixnum pad-00 CHAR: Z write1 ;
|
||||
dup timestamp-month write-00 CHAR: - write1
|
||||
dup timestamp-day write-00 CHAR: T write1
|
||||
dup timestamp-hour write-00 CHAR: : write1
|
||||
dup timestamp-minute write-00 CHAR: : write1
|
||||
timestamp-second >fixnum write-00 CHAR: Z write1 ;
|
||||
|
||||
: timestamp>rfc3339 ( timestamp -- str )
|
||||
>gmt [ (timestamp>rfc3339) ] string-out ;
|
||||
|
|
@ -390,8 +392,8 @@ M: timestamp year. ( timestamp -- )
|
|||
[ timestamp-month month-abbreviations nth write ] keep bl
|
||||
[ timestamp-day number>string 2 32 pad-left write ] keep bl
|
||||
dup now [ timestamp-year ] 2apply = [
|
||||
[ timestamp-hour pad-00 ] keep ":" write
|
||||
timestamp-minute pad-00
|
||||
[ timestamp-hour write-00 ] keep ":" write
|
||||
timestamp-minute write-00
|
||||
] [
|
||||
timestamp-year number>string 5 32 pad-left write
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -0,0 +1,15 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: calendar namespaces models threads init ;
|
||||
IN: calendar.model
|
||||
|
||||
SYMBOL: time
|
||||
|
||||
: (time-thread) ( -- )
|
||||
now time get set-model
|
||||
1000 sleep (time-thread) ;
|
||||
|
||||
: time-thread ( -- ) [ (time-thread) ] in-thread ;
|
||||
|
||||
f <model> time set-global
|
||||
[ time-thread ] "calendar.model" add-init-hook
|
||||
|
|
@ -1 +1 @@
|
|||
Date and time classes
|
||||
Timestamp model updated every second
|
||||
|
|
|
|||
|
|
@ -1,121 +0,0 @@
|
|||
USING: slides help.markup math arrays hashtables namespaces
|
||||
sequences kernel sequences parser ;
|
||||
IN: catalyst-talk
|
||||
|
||||
: catalyst-slides
|
||||
{
|
||||
{ $slide "What is Factor?"
|
||||
"Originally scripting for a Java game"
|
||||
"Language dev more fun than game dev"
|
||||
"Start with ideas which were mostly dead"
|
||||
"Throw in features from crazy languages"
|
||||
"Develop practical libraries and tools"
|
||||
}
|
||||
{ $slide "Factor: a stack language"
|
||||
"Implicit parameter passing"
|
||||
{ "Each " { $emphasis "word" } " is a function call" }
|
||||
{ $code ": sq dup * ;" }
|
||||
{ $code "2 3 + sq ." }
|
||||
"Minimal syntax and semantics = easy meta-programming"
|
||||
{ "Related languages: Forth, Joy, PostScript" }
|
||||
}
|
||||
{ $slide "Factor: a functional language"
|
||||
{ { $emphasis "Quotations" } " can be passed around, constructed..." }
|
||||
{ $code "[ sq 3 + ]" }
|
||||
{ { $emphasis "Combinators" } " are words which take quotations, eg " { $link if } }
|
||||
{ "For FP buffs: " { $link each } ", " { $link map } ", " { $link reduce } ", " { $link accumulate } ", " { $link interleave } ", " { $link subset } }
|
||||
{ $code "{ 42 69 666 } [ sq 3 + ] map ." }
|
||||
}
|
||||
{ $slide "Factor: an object-oriented language"
|
||||
{ "Everything is an " { $emphasis "object" } }
|
||||
{ "An object is an instance of a " { $emphasis "class" } }
|
||||
"Methods"
|
||||
"Generic words"
|
||||
"For CLOS buffs: we allow custom method combination, classes are objects too, there's a MOP"
|
||||
}
|
||||
|
||||
STRIP-TEASE:
|
||||
$slide "Primary school geometry recap"
|
||||
{ $code
|
||||
"GENERIC: area ( shape -- meters^2 )"
|
||||
"TUPLE: square dimension ;"
|
||||
"M: square area square-dimension sq ;"
|
||||
"TUPLE: circle radius ;"
|
||||
"M: circle area circle-radius sq pi * ;"
|
||||
"TUPLE: rectangle width height ;"
|
||||
"M: rectangle area"
|
||||
" dup rectangle-width"
|
||||
" swap rectangle-height"
|
||||
" * ;"
|
||||
}
|
||||
;
|
||||
|
||||
{ $slide "Geometry example"
|
||||
{ $code "10 <square> area ." }
|
||||
{ $code "18 <circle> area ." }
|
||||
{ $code "20 40 <rectangle> area ." }
|
||||
}
|
||||
! { $slide "Factor: a meta language"
|
||||
! "Writing code which writes code"
|
||||
! "Extensible parser: define new syntax"
|
||||
! "Compiler transforms"
|
||||
! "Here's an inefficient word:"
|
||||
! { $code
|
||||
! ": fib ( x -- y )"
|
||||
! " dup 1 > ["
|
||||
! " 1 - dup fib swap 1 - fib +"
|
||||
! " ] when ;"
|
||||
! }
|
||||
! }
|
||||
! { $slide "Memoization"
|
||||
! { { $link POSTPONE: : } " is just another word" }
|
||||
! "What if we could define a word which caches its results?"
|
||||
! { "The " { $vocab-link "memoize" } " library provides such a feature" }
|
||||
! { "Just change " { $link POSTPONE: : } " to " { $link POSTPONE: MEMO: } }
|
||||
! { $code
|
||||
! "MEMO: fib ( x -- y )"
|
||||
! " dup 1 > ["
|
||||
! " 1 - dup fib swap 1 - fib +"
|
||||
! " ] when ;"
|
||||
! }
|
||||
! }
|
||||
{ $slide "Factor: a tool-building language"
|
||||
"Tools are not monolithic, but are themselves just sets of words"
|
||||
"Examples: parser, compiler, etc"
|
||||
"Parser: turns strings into objects"
|
||||
{ $code "\"1\" <file-reader> contents parse" }
|
||||
"Prettyprinter: turns objects into strings"
|
||||
{ $code "\"2\" <file-writer> [ . ] with-stream" }
|
||||
}
|
||||
{ $slide "Factor: an interactive language"
|
||||
{ "Let's hack " { $vocab-link "tetris" } }
|
||||
"Editor integration"
|
||||
{ $code "\\ tetrominoes edit" }
|
||||
"Inspector"
|
||||
{ $code "\\ tetrominoes get inspect" }
|
||||
}
|
||||
{ $slide "C library interface"
|
||||
"No need to write C glue code!"
|
||||
"Callbacks from C to Factor"
|
||||
"Factor can be embedded in C apps"
|
||||
{ "Example: " { $vocab-link "ogg.vorbis" } }
|
||||
{ "Other bindings: OpenGL, OpenAL, X11, Win32, Cocoa, OpenSSL, memory mapped files, ..." }
|
||||
}
|
||||
{ $slide "Native libraries"
|
||||
"XML, HTTP, SMTP, Unicode, calendar, ..."
|
||||
"Lazy lists, pattern matching, packed arrays, ..."
|
||||
}
|
||||
{ $slide "Factor: a fun language"
|
||||
{ "Let's play "
|
||||
{ $vocab-link "space-invaders" }
|
||||
}
|
||||
{ $url "http://factorcode.org" }
|
||||
{ $url "http://factor-language.blogspot.com" }
|
||||
"irc.freenode.net #concatenative"
|
||||
"Have fun!"
|
||||
}
|
||||
} ;
|
||||
|
||||
: catalyst-talk catalyst-slides slides-window ;
|
||||
|
||||
MAIN: catalyst-talk
|
||||
|
|
@ -1 +0,0 @@
|
|||
Slides for a talk at Catalyst IT NZ, July 2007
|
||||
|
|
@ -1,19 +1,19 @@
|
|||
USING: sequences kernel math io ;
|
||||
IN: lcd
|
||||
|
||||
: lcd-digit ( digit row -- str )
|
||||
{
|
||||
" _ _ _ _ _ _ _ _ "
|
||||
" | | | _| _| |_| |_ |_ | |_| |_| "
|
||||
" |_| | |_ _| | _| |_| | |_| | "
|
||||
: lcd-digit ( row digit -- str )
|
||||
dup CHAR: : = [ drop 10 ] [ CHAR: 0 - ] if swap {
|
||||
" _ _ _ _ _ _ _ _ "
|
||||
" | | | _| _| |_| |_ |_ | |_| |_| * "
|
||||
" |_| | |_ _| | _| |_| | |_| | * "
|
||||
} nth >r 4 * dup 4 + r> subseq ;
|
||||
|
||||
: lcd-row ( num row -- )
|
||||
swap [ CHAR: 0 - swap lcd-digit write ] with each ;
|
||||
: lcd-row ( num row -- string )
|
||||
[ swap lcd-digit ] curry { } map-as concat ;
|
||||
|
||||
: lcd ( digit-str -- )
|
||||
3 [ lcd-row nl ] with each ;
|
||||
: lcd ( digit-str -- string )
|
||||
3 [ lcd-row ] with map "\n" join ;
|
||||
|
||||
: lcd-demo ( -- ) "31337" lcd ;
|
||||
: lcd-demo ( -- ) "31337" lcd print ;
|
||||
|
||||
MAIN: lcd-demo
|
||||
|
|
|
|||
|
|
@ -0,0 +1,182 @@
|
|||
USING: slides help.markup math arrays hashtables namespaces
|
||||
sequences kernel sequences parser memoize ;
|
||||
IN: minneapolis-talk
|
||||
|
||||
: minneapolis-slides
|
||||
{
|
||||
{ $slide "What is Factor?"
|
||||
"Dynamically typed, stack language"
|
||||
"Have our cake and eat it too"
|
||||
"Research -vs- production"
|
||||
"High level -vs- performance"
|
||||
"Interactive -vs- stand-alone apps"
|
||||
}
|
||||
{ $slide "The view from 10,000 feet"
|
||||
"Influenced by Forth, Lisp, Joy, Smalltalk, even Java..."
|
||||
"Vocabularies: modules"
|
||||
"Words: named functions, classes, variables"
|
||||
"Combinators: higher-order functions"
|
||||
"Quotations: anonymous functions"
|
||||
}
|
||||
{ $slide "Stack-based programming"
|
||||
{ "Most languages are " { $emphasis "applicative" } }
|
||||
"Words pop inputs from the stack and push outputs on the stack"
|
||||
"Literals are pushed on the stack"
|
||||
{ $code "{ 1 2 } { 7 } append reverse sum ." }
|
||||
}
|
||||
{ $slide "Stack-based programming"
|
||||
"With the stack you can omit unnecessary names"
|
||||
"You can still name things: lexical/dynamic variables, sequences, associations, objects, ..."
|
||||
}
|
||||
{ $slide "Functional programming"
|
||||
"A quotation is a sequence of literals and words"
|
||||
"Combinators replace imperative-style loops"
|
||||
"A simple example:"
|
||||
{ $code "10 [ \"Hello world\" print ] times" }
|
||||
{ "Partial application: " { $link curry } }
|
||||
{ $code "{ 3 1 3 3 7 } [ 5 + ] map ." }
|
||||
{ $code "{ 3 1 3 3 7 } 5 [ + ] curry map ." }
|
||||
}
|
||||
{ $slide "Word definitions"
|
||||
{ $code ": name ( inputs -- outputs )"
|
||||
" definition ;" }
|
||||
"Stack effect comments document stack inputs and outputs."
|
||||
"Example from previous slide:"
|
||||
{ $code ": add-each ( seq n -- newseq )"
|
||||
" [ + ] curry map ;" }
|
||||
{ $code "{ 3 1 3 3 7 } 5 add-each ." }
|
||||
}
|
||||
{ $slide "Object-oriented programming"
|
||||
{ "Define a tuple class and a constructor:"
|
||||
{ $code
|
||||
"TUPLE: person name address ;"
|
||||
"C: <person> person"
|
||||
} }
|
||||
{ "Create an instance:"
|
||||
{ $code
|
||||
"\"Cosmo Kramer\""
|
||||
"\"100 Blah blah St, New York\""
|
||||
"<person>"
|
||||
} }
|
||||
}
|
||||
{ $slide "Object-oriented programming"
|
||||
"We can inspect it and edit objects"
|
||||
"We can reshape the class!"
|
||||
{ $code "TUPLE: person" "name address age phone-number ;" }
|
||||
{ $code "TUPLE: person" "name address phone-number age ;" }
|
||||
}
|
||||
{ $slide "An example"
|
||||
{ $code
|
||||
"TUPLE: square dimension ;"
|
||||
"C: <square> square"
|
||||
""
|
||||
"TUPLE: circle radius ;"
|
||||
"C: <circle> circle"
|
||||
""
|
||||
"TUPLE: rectangle width height ;"
|
||||
"C: <rectangle> rectangle"
|
||||
}
|
||||
}
|
||||
STRIP-TEASE:
|
||||
$slide "An example"
|
||||
{ $code
|
||||
"USE: math.constants"
|
||||
"GENERIC: area ( shape -- meters^2 )"
|
||||
"M: square area square-dimension sq ;"
|
||||
"M: circle area circle-radius sq pi * ;"
|
||||
"M: rectangle area"
|
||||
" dup rectangle-width"
|
||||
" swap rectangle-height * ;"
|
||||
}
|
||||
;
|
||||
|
||||
{ $slide "An example"
|
||||
{ $code "10 <square> area ." }
|
||||
{ $code "18 <circle> area ." }
|
||||
{ $code "20 40 <rectangle> area ." }
|
||||
}
|
||||
{ $slide "Meta language"
|
||||
"Here's fibonacci:"
|
||||
{ $code
|
||||
": fib ( x -- y )"
|
||||
" dup 1 > ["
|
||||
" 1 - dup fib swap 1 - fib +"
|
||||
" ] when ;"
|
||||
}
|
||||
"It is slow:"
|
||||
{ $code
|
||||
"35 [ fib ] map ."
|
||||
}
|
||||
"Let's profile it!"
|
||||
}
|
||||
{ $slide "Memoization"
|
||||
{ { $link POSTPONE: : } " is just another word" }
|
||||
"What if we could define a word which caches its results?"
|
||||
{ "The " { $vocab-link "memoize" } " library provides such a feature" }
|
||||
{ "Just change " { $link POSTPONE: : } " to " { $link POSTPONE: MEMO: } }
|
||||
}
|
||||
{ $slide "Memoization"
|
||||
{ $code
|
||||
"USE: memoize"
|
||||
""
|
||||
"MEMO: fib ( x -- y )"
|
||||
" dup 1 > ["
|
||||
" 1 - dup fib swap 1 - fib +"
|
||||
" ] when ;"
|
||||
}
|
||||
"It is faster:"
|
||||
{ $code
|
||||
"35 [ fib ] map ."
|
||||
}
|
||||
}
|
||||
{ $slide "The Factor UI"
|
||||
"Written in Factor"
|
||||
"Renders with OpenGL"
|
||||
"Backends for Windows, X11, Cocoa"
|
||||
"You can call Windows, X11, Cocoa APIs directly too"
|
||||
"OpenGL 2.1 shaders, OpenAL 3D audio..."
|
||||
}
|
||||
{ $slide "Live coding demo"
|
||||
|
||||
}
|
||||
{ $slide "C library interface"
|
||||
"Efficient"
|
||||
"No need to write C code"
|
||||
"Supports floats, structs, unions, ..."
|
||||
"Function pointers, callbacks"
|
||||
}
|
||||
{ $slide "Live coding demo"
|
||||
|
||||
}
|
||||
{ $slide "Deployment"
|
||||
{ "Let's play " { $vocab-link "tetris" } }
|
||||
}
|
||||
{ $slide "Implementation"
|
||||
"Portable: Windows, Mac OS X, Linux"
|
||||
"Non-optimizing compiler"
|
||||
"Optimizing compiler: x86, x86-64, PowerPC, ARM"
|
||||
"Generational garbage collector"
|
||||
"Non-blocking I/O"
|
||||
}
|
||||
{ $slide "Some statistics"
|
||||
"VM: 11,800 lines of C"
|
||||
"Core library: 22,600 lines of Factor"
|
||||
"Docs, tests, extra libraries: 117,000 lines of Factor"
|
||||
}
|
||||
{ $slide "But wait, there's more!"
|
||||
"Web server and framework, syntax highlighting, Ogg Theora video, SMTP, embedded Prolog, efficient unboxed arrays, XML, Unicode 5.0, memory mapped files, regular expressions, LDAP, database access, coroutines, Factor->JavaScript compiler, JSON, pattern matching, advanced math, parser generators, serialization, RSS/Atom, ..."
|
||||
}
|
||||
{ $slide "Community"
|
||||
"Factor development began in 2003"
|
||||
"About a dozen contributors"
|
||||
"Handful of \"core contributors\""
|
||||
{ "Web site: " { $url "http://factorcode.org" } }
|
||||
"IRC: #concatenative on irc.freenode.net"
|
||||
"Mailing list: factor-talk@lists.sf.net"
|
||||
}
|
||||
{ $slide "Questions?" }
|
||||
} ;
|
||||
|
||||
: minneapolis-talk minneapolis-slides slides-window ;
|
||||
|
||||
MAIN: minneapolis-talk
|
||||
|
|
@ -0,0 +1,116 @@
|
|||
- how to create a small module
|
||||
- editor integration
|
||||
- presentations
|
||||
- module system
|
||||
- copy and paste factoring, inverse
|
||||
- help system
|
||||
- tetris
|
||||
- memoization
|
||||
- editing inspector demo
|
||||
- dynamic scope, lexical scope
|
||||
|
||||
Factor: contradictions?
|
||||
-----------------------
|
||||
|
||||
Have our cake and eat it too
|
||||
|
||||
Research -vs- practical
|
||||
High level -vs- fast
|
||||
Interactive -vs- deployment
|
||||
|
||||
Factor from 10,000 feet
|
||||
-----------------------
|
||||
|
||||
word: named function
|
||||
vocabulary: module
|
||||
quotation: anonymous function
|
||||
classes, objects, etc.
|
||||
|
||||
The stack
|
||||
---------
|
||||
|
||||
- Stack -vs- applicative
|
||||
- Pass by reference, dynamically typed
|
||||
- Stack languages: you can omit names where they're not needed
|
||||
- More compositional style
|
||||
- If you need to name things for clarity, you can:
|
||||
lexical vars, dynamic vars, sequences, assocs, objects...
|
||||
|
||||
Functional programming
|
||||
----------------------
|
||||
|
||||
Quotations
|
||||
Curry
|
||||
Continuations
|
||||
|
||||
Object-oriented programming
|
||||
---------------------------
|
||||
|
||||
Generic words: sort of like open classes
|
||||
Tuple reshaping
|
||||
Editing inspector
|
||||
|
||||
Meta programming
|
||||
----------------
|
||||
|
||||
Simple, orthogonal core
|
||||
|
||||
Why use a stack at all?
|
||||
-----------------------
|
||||
|
||||
Nice idioms: 10 days ago
|
||||
Copy and paste factoring
|
||||
Easy meta-programming
|
||||
Sequence operations correspond to functional operations:
|
||||
- curry is adding at the front
|
||||
- compose is append
|
||||
|
||||
UI
|
||||
--
|
||||
|
||||
Written in Factor
|
||||
renders with OpenGL
|
||||
Windows, X11, Cocoa backends
|
||||
You can call Windows, X11, Cocoa APIs directly
|
||||
OpenGL 2.1 shaders, OpenAL 3D audio...
|
||||
|
||||
Tools
|
||||
-----
|
||||
|
||||
Edit
|
||||
Usages
|
||||
Profiler
|
||||
Easy to make your own tools
|
||||
|
||||
Implementation
|
||||
--------------
|
||||
|
||||
Two compilers
|
||||
Generational garbage collector
|
||||
Non-blocking I/O
|
||||
|
||||
Hands on
|
||||
--------
|
||||
|
||||
Community
|
||||
---------
|
||||
|
||||
Factor started in 2003
|
||||
About a dozen contributors
|
||||
Handful of "core contributors"
|
||||
Web site: http://factorcode.org
|
||||
IRC: #concatenative on irc.freenode.net
|
||||
Mailing list: factor-talk@lists.sf.net
|
||||
|
||||
C library interface
|
||||
-------------------
|
||||
|
||||
Efficient
|
||||
No need to write C code
|
||||
Supports floats, structs, unions, ...
|
||||
Function pointers, callbacks
|
||||
Here is an example
|
||||
|
||||
TerminateProcess
|
||||
|
||||
process-handle TerminateProcess
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slides for a talk at Ruby.mn, Minneapolis MN, January 2008
|
||||
|
|
@ -9,50 +9,77 @@ quotations io.launcher words.private tools.deploy.config
|
|||
bootstrap.image ;
|
||||
IN: tools.deploy.backend
|
||||
|
||||
: boot-image-name ( -- string )
|
||||
"boot." my-arch ".image" 3append ;
|
||||
|
||||
: stage1 ( -- )
|
||||
#! If stage1 image doesn't exist, create one.
|
||||
boot-image-name resource-path exists?
|
||||
[ my-arch make-image ] unless ;
|
||||
|
||||
: (copy-lines) ( stream -- stream )
|
||||
dup stream-readln [ print flush (copy-lines) ] when* ;
|
||||
|
||||
: copy-lines ( stream -- )
|
||||
[ (copy-lines) ] [ stream-close ] [ ] cleanup ;
|
||||
|
||||
: ?append swap [ append ] [ drop ] if ;
|
||||
: run-with-output ( descriptor -- )
|
||||
<process-stream>
|
||||
dup duplex-stream-out stream-close
|
||||
copy-lines ;
|
||||
|
||||
: profile-string ( config -- string )
|
||||
: boot-image-name ( -- string )
|
||||
"boot." my-arch ".image" 3append ;
|
||||
|
||||
: make-boot-image ( -- )
|
||||
#! If stage1 image doesn't exist, create one.
|
||||
boot-image-name resource-path exists?
|
||||
[ my-arch make-image ] unless ;
|
||||
|
||||
: ?, [ , ] [ drop ] if ;
|
||||
|
||||
: bootstrap-profile ( config -- profile )
|
||||
[
|
||||
""
|
||||
deploy-math? get " math" ?append
|
||||
deploy-compiler? get " compiler" ?append
|
||||
deploy-ui? get " ui" ?append
|
||||
native-io? " io" ?append
|
||||
[
|
||||
"math" deploy-math? get ?,
|
||||
"compiler" deploy-compiler? get ?,
|
||||
"ui" deploy-ui? get ?,
|
||||
"io" native-io? ?,
|
||||
] { } make
|
||||
] bind ;
|
||||
|
||||
: deploy-command-line ( vm image vocab config -- vm flags )
|
||||
: staging-image-name ( profile -- name )
|
||||
"staging." swap bootstrap-profile "-" join ".image" 3append ;
|
||||
|
||||
: staging-command-line ( config -- flags )
|
||||
[
|
||||
"-include=" swap profile-string append ,
|
||||
"-i=" boot-image-name append ,
|
||||
|
||||
"-deploy-vocab=" swap append ,
|
||||
"-output-image=" over staging-image-name append ,
|
||||
|
||||
"-output-image=" swap append ,
|
||||
"-include=" swap bootstrap-profile " " join append ,
|
||||
|
||||
"-no-stack-traces" ,
|
||||
|
||||
"-no-user-init" ,
|
||||
] { } make ;
|
||||
|
||||
: stage2 ( vm image vocab config -- )
|
||||
deploy-command-line
|
||||
>r "-i=" boot-image-name append 2array r> append dup .
|
||||
<process-stream>
|
||||
dup duplex-stream-out stream-close
|
||||
copy-lines ;
|
||||
: run-factor ( vm flags -- )
|
||||
dup . swap add* run-with-output ; inline
|
||||
|
||||
: make-staging-image ( vm config -- )
|
||||
staging-command-line run-factor ;
|
||||
|
||||
: deploy-command-line ( image vocab config -- flags )
|
||||
[
|
||||
"-i=" swap staging-image-name append ,
|
||||
|
||||
"-run=tools.deploy.shaker" ,
|
||||
|
||||
"-deploy-vocab=" swap append ,
|
||||
|
||||
"-output-image=" swap append ,
|
||||
|
||||
"-no-stack-traces" ,
|
||||
] { } make ;
|
||||
|
||||
: make-deploy-image ( vm image vocab config -- )
|
||||
dup staging-image-name exists? [
|
||||
>r pick r> tuck make-staging-image
|
||||
] unless
|
||||
deploy-command-line run-factor ;
|
||||
|
||||
SYMBOL: deploy-implementation
|
||||
|
||||
|
|
|
|||
|
|
@ -72,13 +72,12 @@ T{ macosx-deploy-implementation } deploy-implementation set-global
|
|||
-> selectFile:inFileViewerRootedAtPath: drop ;
|
||||
|
||||
M: macosx-deploy-implementation deploy* ( vocab -- )
|
||||
stage1
|
||||
".app deploy tool" assert.app
|
||||
"." resource-path cd
|
||||
dup deploy-config [
|
||||
bundle-name rm
|
||||
[ bundle-name create-app-dir ] keep
|
||||
[ bundle-name deploy.app-image ] keep
|
||||
namespace stage2
|
||||
namespace make-deploy-image
|
||||
bundle-name show-in-finder
|
||||
] bind ;
|
||||
|
|
|
|||
|
|
@ -34,11 +34,10 @@ TUPLE: windows-deploy-implementation ;
|
|||
T{ windows-deploy-implementation } deploy-implementation set-global
|
||||
|
||||
M: windows-deploy-implementation deploy*
|
||||
stage1
|
||||
"." resource-path cd
|
||||
dup deploy-config [
|
||||
[ deploy-name get create-exe-dir ] keep
|
||||
[ deploy-name get image-name ] keep
|
||||
[ namespace stage2 ] keep
|
||||
[ namespace make-deploy-image ] keep
|
||||
open-in-explorer
|
||||
] bind ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien 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 io.mmap ;
|
||||
ui.gadgets.worlds ui.render ui.backend byte-arrays ;
|
||||
IN: ui.freetype
|
||||
|
||||
TUPLE: freetype-renderer ;
|
||||
|
|
@ -63,18 +63,23 @@ M: freetype-renderer free-fonts ( world -- )
|
|||
: ttf-path ( name -- string )
|
||||
"/fonts/" swap ".ttf" 3append resource-path ;
|
||||
|
||||
: (open-face) ( mapped-file -- face )
|
||||
: (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 swap dup mapped-file-address swap length 0 f
|
||||
<void*> [ FT_New_Memory_Face freetype-error ] keep *void* ;
|
||||
freetype -rot 0 f <void*> [
|
||||
FT_New_Memory_Face freetype-error
|
||||
] keep *void* ;
|
||||
|
||||
: open-face ( font style -- face )
|
||||
ttf-name ttf-path dup file-length
|
||||
<mapped-file> (open-face) ;
|
||||
ttf-name ttf-path
|
||||
dup file-contents >byte-array malloc-byte-array
|
||||
swap file-length
|
||||
(open-face) ;
|
||||
|
||||
: dpi 72 ; inline
|
||||
SYMBOL: dpi
|
||||
|
||||
72 dpi set-global
|
||||
|
||||
: ft-floor -6 shift ; inline
|
||||
|
||||
|
|
@ -101,7 +106,8 @@ M: freetype-renderer free-fonts ( world -- )
|
|||
|
||||
: (open-font) ( font -- open-font )
|
||||
first3 >r open-face dup 0 r> 6 shift
|
||||
dpi dpi FT_Set_Char_Size freetype-error <font> ;
|
||||
dpi get-global dpi get-global FT_Set_Char_Size
|
||||
freetype-error <font> ;
|
||||
|
||||
M: freetype-renderer open-font ( font -- open-font )
|
||||
freetype drop open-fonts get [ (open-font) ] cache ;
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ M: label gadget-text* label-string % ;
|
|||
TUPLE: label-control ;
|
||||
|
||||
M: label-control model-changed
|
||||
swap model-value over set-label-text relayout ;
|
||||
swap model-value over set-label-string relayout ;
|
||||
|
||||
: <label-control> ( model -- gadget )
|
||||
"" <label> label-control construct-control ;
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@ SYMBOL: ui-hook
|
|||
: 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 activate-control ungraft* ] }
|
||||
{ { t f } [ dup deactivate-control ungraft* ] }
|
||||
} case ;
|
||||
|
||||
: notify-queued ( -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue