Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
5c2a734a54
|
|
@ -652,10 +652,10 @@ M: ppc %alien-callback ( quot -- )
|
|||
|
||||
M: ppc %prepare-alien-indirect ( -- )
|
||||
"unbox_alien" f %alien-invoke
|
||||
13 3 MR ;
|
||||
15 3 MR ;
|
||||
|
||||
M: ppc %alien-indirect ( -- )
|
||||
13 MTLR BLRL ;
|
||||
15 MTLR BLRL ;
|
||||
|
||||
M: ppc %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
|
|
@ -713,3 +713,4 @@ USE: vocabs.loader
|
|||
} cond
|
||||
|
||||
"complex-double" c-type t >>return-in-registers? drop
|
||||
"bool" c-type 4 >>size 4 >>align drop
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
IN: io.backend.windows.privileges.tests
|
||||
USING: io.backend.windows.privileges tools.test ;
|
||||
|
||||
[ [ ] with-privileges ] must-infer
|
||||
|
|
@ -1,12 +1,13 @@
|
|||
USING: io.backend kernel continuations sequences
|
||||
system vocabs.loader combinators ;
|
||||
system vocabs.loader combinators fry ;
|
||||
IN: io.backend.windows.privileges
|
||||
|
||||
HOOK: set-privilege io-backend ( name ? -- ) inline
|
||||
HOOK: set-privilege io-backend ( name ? -- )
|
||||
|
||||
: with-privileges ( seq quot -- )
|
||||
over [ [ t set-privilege ] each ] curry compose
|
||||
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
|
||||
[ '[ _ [ t set-privilege ] each @ ] ]
|
||||
[ drop '[ _ [ f set-privilege ] each ] ]
|
||||
2bi [ ] cleanup ; inline
|
||||
|
||||
{
|
||||
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }
|
||||
|
|
|
|||
|
|
@ -35,6 +35,9 @@ SYMBOL: unique-retries
|
|||
: random-name ( -- string )
|
||||
unique-length get [ random-ch ] "" replicate-as ;
|
||||
|
||||
: retry ( quot: ( -- ? ) n -- )
|
||||
swap [ drop ] prepose attempt-all ; inline
|
||||
|
||||
: (make-unique-file) ( path prefix suffix -- path )
|
||||
'[
|
||||
_ _ _ random-name glue append-path
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-run=listener" 2array >>command
|
||||
+closed+ >>stdin
|
||||
+stdout+ >>stderr
|
||||
ascii [ input-stream get contents ] with-process-reader
|
||||
ascii [ contents ] with-process-reader
|
||||
] unit-test
|
||||
|
||||
: launcher-test-path ( -- str )
|
||||
|
|
@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests
|
|||
<process>
|
||||
console-vm "-script" "stderr.factor" 3array >>command
|
||||
"err2.txt" temp-file >>stderr
|
||||
ascii <process-reader> lines first
|
||||
ascii <process-reader> stream-lines first
|
||||
] with-directory
|
||||
] unit-test
|
||||
|
||||
|
|
@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests
|
|||
launcher-test-path [
|
||||
<process>
|
||||
console-vm "-script" "env.factor" 3array >>command
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
os-envs =
|
||||
|
|
@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-script" "env.factor" 3array >>command
|
||||
+replace-environment+ >>environment-mode
|
||||
os-envs >>environment
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
os-envs =
|
||||
|
|
@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests
|
|||
<process>
|
||||
console-vm "-script" "env.factor" 3array >>command
|
||||
{ { "A" "B" } } >>environment
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
"A" swap at
|
||||
|
|
@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests
|
|||
console-vm "-script" "env.factor" 3array >>command
|
||||
{ { "USERPROFILE" "XXX" } } >>environment
|
||||
+prepend-environment+ >>environment-mode
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] with-directory eval( -- alist )
|
||||
|
||||
"USERPROFILE" swap at "XXX" =
|
||||
|
|
|
|||
|
|
@ -5,8 +5,6 @@ random sequences sets combinators.short-circuit math.bitwise
|
|||
math math.order ;
|
||||
IN: math.miller-rabin
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: >odd ( n -- int ) 0 set-bit ; foldable
|
||||
|
||||
: >even ( n -- int ) 0 clear-bit ; foldable
|
||||
|
|
@ -15,7 +13,7 @@ IN: math.miller-rabin
|
|||
|
||||
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
|
||||
|
||||
TUPLE: positive-even-expected n ;
|
||||
<PRIVATE
|
||||
|
||||
:: (miller-rabin) ( n trials -- ? )
|
||||
n 1 - :> n-1
|
||||
|
|
|
|||
|
|
@ -39,6 +39,8 @@ SLOT: display-list
|
|||
|
||||
GENERIC: draw-scaled-texture ( dim texture -- )
|
||||
|
||||
DEFER: make-texture
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
|
||||
|
|
@ -61,18 +63,6 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
|
|||
[ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
|
||||
glTexSubImage2D ;
|
||||
|
||||
: make-texture ( image -- id )
|
||||
#! We use glTexSubImage2D to work around the power of 2 texture size
|
||||
#! limitation
|
||||
gen-texture [
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
non-power-of-2-textures? get
|
||||
[ dup bitmap>> (tex-image) ]
|
||||
[ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
|
||||
] do-attribs
|
||||
] keep ;
|
||||
|
||||
: init-texture ( -- )
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
|
||||
|
|
@ -176,6 +166,18 @@ CONSTANT: max-texture-size { 512 512 }
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: make-texture ( image -- id )
|
||||
#! We use glTexSubImage2D to work around the power of 2 texture size
|
||||
#! limitation
|
||||
gen-texture [
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_2D swap glBindTexture
|
||||
non-power-of-2-textures? get
|
||||
[ dup bitmap>> (tex-image) ]
|
||||
[ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
|
||||
] do-attribs
|
||||
] keep ;
|
||||
|
||||
: <texture> ( image loc -- texture )
|
||||
over dim>> max-texture-size [ <= ] 2all?
|
||||
[ <single-texture> ]
|
||||
|
|
|
|||
|
|
@ -23,7 +23,13 @@ IN: tools.deploy.shaker
|
|||
|
||||
: strip-init-hooks ( -- )
|
||||
"Stripping startup hooks" show
|
||||
{ "cpu.x86" "command-line" "libc" "system" "environment" }
|
||||
{
|
||||
"command-line"
|
||||
"cpu.x86"
|
||||
"environment"
|
||||
"libc"
|
||||
"alien.strings"
|
||||
}
|
||||
[ init-hooks get delete-at ] each
|
||||
deploy-threads? get [
|
||||
"threads" init-hooks get delete-at
|
||||
|
|
@ -36,8 +42,12 @@ IN: tools.deploy.shaker
|
|||
"io.backend" init-hooks get delete-at
|
||||
] when
|
||||
strip-dictionary? [
|
||||
"compiler.units" init-hooks get delete-at
|
||||
"vocabs.cache" init-hooks get delete-at
|
||||
{
|
||||
"compiler.units"
|
||||
"vocabs"
|
||||
"vocabs.cache"
|
||||
"source-files.errors"
|
||||
} [ init-hooks get delete-at ] each
|
||||
] when ;
|
||||
|
||||
: strip-debugger ( -- )
|
||||
|
|
@ -260,21 +270,20 @@ IN: tools.deploy.shaker
|
|||
compiler.errors:compiler-errors
|
||||
definition-observers
|
||||
interactive-vocabs
|
||||
layouts:num-tags
|
||||
layouts:num-types
|
||||
layouts:tag-mask
|
||||
layouts:tag-numbers
|
||||
layouts:type-numbers
|
||||
lexer-factory
|
||||
print-use-hook
|
||||
root-cache
|
||||
source-files.errors:error-types
|
||||
source-files.errors:error-observers
|
||||
vocabs:dictionary
|
||||
vocabs:load-vocab-hook
|
||||
vocabs:vocab-observers
|
||||
word
|
||||
parser-notes
|
||||
} %
|
||||
|
||||
{ } { "layouts" } strip-vocab-globals %
|
||||
|
||||
{ } { "math.partial-dispatch" } strip-vocab-globals %
|
||||
|
||||
{ } { "peg" } strip-vocab-globals %
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{
|
|||
{ fullscreen { $ NSOpenGLPFAFullScreen } }
|
||||
{ windowed { $ NSOpenGLPFAWindow } }
|
||||
{ accelerated { $ NSOpenGLPFAAccelerated } }
|
||||
{ software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } }
|
||||
{ software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } }
|
||||
{ backing-store { $ NSOpenGLPFABackingStore } }
|
||||
{ multisampled { $ NSOpenGLPFAMultisample } }
|
||||
{ supersampled { $ NSOpenGLPFASupersample } }
|
||||
|
|
|
|||
|
|
@ -79,7 +79,6 @@ $nl
|
|||
{ $subsection continue-with }
|
||||
"Continuations as control-flow:"
|
||||
{ $subsection attempt-all }
|
||||
{ $subsection retry }
|
||||
{ $subsection with-return }
|
||||
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
|
||||
{ $subsection "continuations.private" } ;
|
||||
|
|
@ -232,21 +231,6 @@ HELP: attempt-all
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: retry
|
||||
{ $values
|
||||
{ "quot" quotation } { "n" integer }
|
||||
}
|
||||
{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
|
||||
{ $examples
|
||||
"Try to get a 0 as a random number:"
|
||||
{ $unchecked-example "USING: continuations math prettyprint random ;"
|
||||
"[ 5 random 0 = ] 5 retry"
|
||||
"t"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ attempt-all retry } related-words
|
||||
|
||||
HELP: return
|
||||
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -155,8 +155,6 @@ ERROR: attempt-all-error ;
|
|||
] { } make peek swap [ rethrow ] when
|
||||
] if ; inline
|
||||
|
||||
: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline
|
||||
|
||||
TUPLE: condition error restarts continuation ;
|
||||
|
||||
C: <condition> condition ( error restarts cc -- condition )
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ M: bunny-buffers bunny-geom
|
|||
GL_FLOAT 0 0 buffer-offset glNormalPointer
|
||||
[
|
||||
nv>> "float" heap-size * buffer-offset
|
||||
3 GL_FLOAT 0 roll glVertexPointer
|
||||
[ 3 GL_FLOAT 0 ] dip glVertexPointer
|
||||
] [
|
||||
ni>>
|
||||
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
|
||||
|
|
|
|||
|
|
@ -120,7 +120,7 @@ TUPLE: bunny-outlined
|
|||
|
||||
: outlining-supported? ( -- ? )
|
||||
"2.0" {
|
||||
"GL_ARB_shading_objects"
|
||||
"GL_ARB_shader_objects"
|
||||
"GL_ARB_draw_buffers"
|
||||
"GL_ARB_multitexture"
|
||||
} has-gl-version-or-extensions? {
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: accessors destructors kernel math math.order namespaces
|
||||
USING: accessors calendar destructors kernel math math.order namespaces
|
||||
system threads ;
|
||||
IN: game-loop
|
||||
|
||||
|
|
@ -50,7 +50,7 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
|
|||
|
||||
: (run-loop) ( loop -- )
|
||||
dup running?>>
|
||||
[ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
|
||||
[ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ]
|
||||
[ drop ] if ;
|
||||
|
||||
: run-loop ( loop -- )
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
USING: tools.deploy.config ;
|
||||
H{
|
||||
{ deploy-name "Hello world (console)" }
|
||||
{ deploy-c-types? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? f }
|
||||
{ deploy-unicode? f }
|
||||
{ deploy-ui? f }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-name "Hello world (console)" }
|
||||
{ deploy-io 2 }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-threads? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-math? f }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-word-defs? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
}
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ M: image <image-gadget>
|
|||
|
||||
M: string <image-gadget> load-image <image-gadget> ;
|
||||
|
||||
M: pathname <image-gadget> load-image <image-gadget> ;
|
||||
M: pathname <image-gadget> string>> load-image <image-gadget> ;
|
||||
|
||||
: image-window ( object -- ) <image-gadget> "Image" open-window ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel calendar io.directories io.encodings.utf8
|
||||
io.files io.launcher mason.child mason.cleanup mason.common
|
||||
mason.help mason.release mason.report mason.email mason.notify
|
||||
namespaces prettyprint ;
|
||||
io.files io.launcher namespaces prettyprint mason.child mason.cleanup
|
||||
mason.common mason.help mason.release mason.report mason.email
|
||||
mason.notify ;
|
||||
IN: mason.build
|
||||
|
||||
QUALIFIED: continuations
|
||||
|
|
@ -19,7 +19,10 @@ QUALIFIED: continuations
|
|||
|
||||
: begin-build ( -- )
|
||||
"factor" [ git-id ] with-directory
|
||||
[ "git-id" to-file ] [ notify-begin-build ] bi ;
|
||||
[ "git-id" to-file ]
|
||||
[ current-git-id set ]
|
||||
[ notify-begin-build ]
|
||||
tri ;
|
||||
|
||||
: build ( -- )
|
||||
create-build-dir
|
||||
|
|
|
|||
|
|
@ -4,9 +4,12 @@ USING: kernel namespaces sequences splitting system accessors
|
|||
math.functions make io io.files io.pathnames io.directories
|
||||
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
|
||||
combinators.short-circuit parser combinators calendar
|
||||
calendar.format arrays mason.config locals system debugger ;
|
||||
calendar.format arrays mason.config locals system debugger fry
|
||||
continuations ;
|
||||
IN: mason.common
|
||||
|
||||
SYMBOL: current-git-id
|
||||
|
||||
ERROR: output-process-error output process ;
|
||||
|
||||
M: output-process-error error.
|
||||
|
|
@ -35,15 +38,19 @@ M: unix really-delete-tree delete-tree ;
|
|||
<process>
|
||||
swap >>command
|
||||
15 minutes >>timeout
|
||||
+closed+ >>stdin
|
||||
try-output-process ;
|
||||
|
||||
: retry ( n quot -- )
|
||||
'[ drop @ f ] attempt-all drop ; inline
|
||||
|
||||
:: upload-safely ( local username host remote -- )
|
||||
[let* | temp [ remote ".incomplete" append ]
|
||||
scp-remote [ { username "@" host ":" temp } concat ]
|
||||
scp [ scp-command get ]
|
||||
ssh [ ssh-command get ] |
|
||||
{ scp local scp-remote } short-running-process
|
||||
{ ssh host "-l" username "mv" temp remote } short-running-process
|
||||
5 [ { scp local scp-remote } short-running-process ] retry
|
||||
5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry
|
||||
] ;
|
||||
|
||||
: eval-file ( file -- obj )
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
IN: mason.email.tests
|
||||
USING: mason.email mason.common mason.config namespaces tools.test ;
|
||||
|
||||
[ "mason on linux-x86-64: error" ] [
|
||||
[ "mason on linux-x86-64: 12345 -- error" ] [
|
||||
[
|
||||
"linux" target-os set
|
||||
"x86.64" target-cpu set
|
||||
"12345" current-git-id set
|
||||
status-error subject prefix-subject
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces accessors combinators make smtp debugger
|
||||
prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets
|
||||
mason.common mason.platform mason.config ;
|
||||
prettyprint sequences io io.streams.string io.encodings.utf8 io.files
|
||||
io.sockets mason.common mason.platform mason.config ;
|
||||
IN: mason.email
|
||||
|
||||
: prefix-subject ( str -- str' )
|
||||
|
|
@ -18,11 +18,11 @@ IN: mason.email
|
|||
send-email ;
|
||||
|
||||
: subject ( status -- str )
|
||||
{
|
||||
[ current-git-id get 7 short head " -- " ] dip {
|
||||
{ status-clean [ "clean" ] }
|
||||
{ status-dirty [ "dirty" ] }
|
||||
{ status-error [ "error" ] }
|
||||
} case ;
|
||||
} case 3append ;
|
||||
|
||||
: email-report ( report status -- )
|
||||
[ "text/html" ] dip subject email-status ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.directories io.files io.launcher kernel make
|
||||
mason.common mason.config mason.platform namespaces prettyprint
|
||||
sequences ;
|
||||
namespaces prettyprint sequences mason.common mason.config
|
||||
mason.platform ;
|
||||
IN: mason.release.branch
|
||||
|
||||
: branch-name ( -- string ) "clean-" platform append ;
|
||||
|
|
@ -21,7 +21,7 @@ IN: mason.release.branch
|
|||
] { } make ;
|
||||
|
||||
: push-to-clean-branch ( -- )
|
||||
push-to-clean-branch-cmd short-running-process ;
|
||||
5 [ push-to-clean-branch-cmd short-running-process ] retry ;
|
||||
|
||||
: upload-clean-image-cmd ( -- args )
|
||||
[
|
||||
|
|
@ -36,7 +36,7 @@ IN: mason.release.branch
|
|||
] { } make ;
|
||||
|
||||
: upload-clean-image ( -- )
|
||||
upload-clean-image-cmd short-running-process ;
|
||||
5 [ upload-clean-image-cmd short-running-process ] retry ;
|
||||
|
||||
: (update-clean-branch) ( -- )
|
||||
"factor" [
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ IN: mason.report
|
|||
target-cpu get
|
||||
host-name
|
||||
build-dir
|
||||
"git-id" eval-file
|
||||
current-git-id get
|
||||
[XML
|
||||
<h1>Build report for <->/<-></h1>
|
||||
<table>
|
||||
|
|
|
|||
|
|
@ -7,6 +7,9 @@ IN: noise
|
|||
: <perlin-noise-table> ( -- table )
|
||||
256 iota >byte-array randomize dup append ;
|
||||
|
||||
: with-seed ( seed quot -- )
|
||||
[ <mersenne-twister> ] dip with-random ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: fade ( point -- point' )
|
||||
|
|
@ -54,9 +57,6 @@ IN: noise
|
|||
v w quot call
|
||||
; inline
|
||||
|
||||
: with-seed ( seed quot -- )
|
||||
[ <mersenne-twister> ] dip with-random ; inline
|
||||
|
||||
: >byte-map ( floats -- bytes )
|
||||
[ 255.0 * >fixnum ] B{ } map-as ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
USING: arrays kernel math math.functions math.order math.vectors
|
||||
namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
|
||||
ui.gadgets.worlds ui.render accessors combinators ;
|
||||
ui.gadgets.worlds ui.render accessors combinators literals ;
|
||||
IN: opengl.demo-support
|
||||
|
||||
: FOV ( -- x ) 2.0 sqrt 1+ ; inline
|
||||
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
|
||||
CONSTANT: MOUSE-MOTION-SCALE 0.5
|
||||
CONSTANT: KEY-ROTATE-STEP 10.0
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,60 @@
|
|||
USING: accessors arrays byte-arrays combinators fry grouping
|
||||
images kernel math math.affine-transforms math.order
|
||||
math.vectors noise random sequences ;
|
||||
IN: terrain.generation
|
||||
|
||||
CONSTANT: terrain-segment-size { 512 512 }
|
||||
CONSTANT: terrain-big-noise-scale { 0.002 0.002 }
|
||||
CONSTANT: terrain-small-noise-scale { 0.05 0.05 }
|
||||
|
||||
TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ;
|
||||
|
||||
: <terrain> ( -- terrain )
|
||||
<perlin-noise-table> <perlin-noise-table>
|
||||
32 random-bits terrain boa ;
|
||||
|
||||
: seed-at ( seed at -- seed' )
|
||||
first2 [ + ] dip [ 32 random-bits + ] curry with-seed ;
|
||||
|
||||
: big-noise-segment ( terrain at -- map )
|
||||
[ big-noise-table>> terrain-big-noise-scale first2 <scale> ] dip
|
||||
terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
|
||||
: small-noise-segment ( terrain at -- map )
|
||||
[ small-noise-table>> terrain-small-noise-scale first2 <scale> ] dip
|
||||
terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
|
||||
: tiny-noise-segment ( terrain at -- map )
|
||||
[ tiny-noise-seed>> ] dip seed-at 0.1
|
||||
terrain-segment-size normal-noise-byte-map ;
|
||||
|
||||
: padding ( terrain at -- padding )
|
||||
2drop terrain-segment-size product 255 <repetition> ;
|
||||
|
||||
TUPLE: segment image ;
|
||||
|
||||
: terrain-segment ( terrain at -- image )
|
||||
{
|
||||
[ big-noise-segment ]
|
||||
[ small-noise-segment ]
|
||||
[ tiny-noise-segment ]
|
||||
[ padding ]
|
||||
} 2cleave
|
||||
4array flip concat >byte-array
|
||||
[ terrain-segment-size RGBA f ] dip image boa ;
|
||||
|
||||
: 4max ( a b c d -- max )
|
||||
max max max ; inline
|
||||
|
||||
: mipmap ( {{pixels}} quot: ( aa ab ba bb -- c ) -- pixels' )
|
||||
[ [ 2 <groups> ] map 2 <groups> ] dip
|
||||
'[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline
|
||||
|
||||
: group-pixels ( bitmap dim -- scanlines )
|
||||
[ 4 <groups> ] [ first <groups> ] bi* ;
|
||||
|
||||
: concat-pixels ( scanlines -- bitmap )
|
||||
[ concat ] map concat ;
|
||||
|
||||
: segment-mipmap ( image -- image' )
|
||||
[ clone ] [ bitmap>> ] [ dim>> ] tri
|
||||
group-pixels [ 4max ] mipmap concat-pixels >>bitmap
|
||||
[ 2 v/n ] change-dim ;
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
USING: multiline ;
|
||||
IN: terrain.shaders
|
||||
|
||||
STRING: terrain-vertex-shader
|
||||
|
||||
uniform sampler2D heightmap;
|
||||
|
||||
varying vec2 heightcoords;
|
||||
|
||||
const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
|
||||
|
||||
float height(sampler2D map, vec2 coords)
|
||||
{
|
||||
vec4 v = texture2D(map, coords);
|
||||
return dot(v, COMPONENT_SCALE);
|
||||
}
|
||||
|
||||
void main()
|
||||
{
|
||||
gl_Position = gl_ModelViewProjectionMatrix
|
||||
* (gl_Vertex + vec4(0, height(heightmap, gl_Vertex.xz), 0, 0));
|
||||
heightcoords = gl_Vertex.xz;
|
||||
}
|
||||
|
||||
;
|
||||
|
||||
STRING: terrain-pixel-shader
|
||||
|
||||
uniform sampler2D heightmap;
|
||||
|
||||
varying vec2 heightcoords;
|
||||
|
||||
const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
|
||||
|
||||
float height(sampler2D map, vec2 coords)
|
||||
{
|
||||
vec4 v = texture2D(map, coords);
|
||||
return dot(v, COMPONENT_SCALE);
|
||||
}
|
||||
|
||||
void main()
|
||||
{
|
||||
gl_FragColor = texture2D(heightmap, heightcoords);
|
||||
}
|
||||
|
||||
;
|
||||
|
|
@ -0,0 +1,190 @@
|
|||
USING: accessors arrays combinators game-input
|
||||
game-input.scancodes game-loop kernel literals locals math
|
||||
math.constants math.functions math.matrices math.order
|
||||
math.vectors opengl opengl.capabilities opengl.gl
|
||||
opengl.shaders opengl.textures opengl.textures.private
|
||||
sequences sequences.product specialized-arrays.float
|
||||
terrain.generation terrain.shaders ui ui.gadgets
|
||||
ui.gadgets.worlds ui.pixel-formats ;
|
||||
IN: terrain
|
||||
|
||||
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
|
||||
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
|
||||
CONSTANT: FAR-PLANE 1.0
|
||||
CONSTANT: EYE-START { 0.5 0.5 1.2 }
|
||||
CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
|
||||
CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
|
||||
CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ]
|
||||
|
||||
CONSTANT: terrain-vertex-size { 512 512 }
|
||||
CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
|
||||
CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
|
||||
|
||||
TUPLE: terrain-world < world
|
||||
eye yaw pitch
|
||||
terrain terrain-segment terrain-texture terrain-program
|
||||
terrain-vertex-buffer
|
||||
game-loop ;
|
||||
|
||||
: frustum ( dim -- -x x -y y near far )
|
||||
dup first2 min v/n
|
||||
NEAR-PLANE FOV / v*n first2 [ [ neg ] keep ] bi@
|
||||
NEAR-PLANE FAR-PLANE ;
|
||||
|
||||
: set-modelview-matrix ( gadget -- )
|
||||
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
|
||||
GL_MODELVIEW glMatrixMode
|
||||
glLoadIdentity
|
||||
[ pitch>> 1.0 0.0 0.0 glRotatef ]
|
||||
[ yaw>> 0.0 1.0 0.0 glRotatef ]
|
||||
[ eye>> vneg first3 glTranslatef ] tri ;
|
||||
|
||||
: vertex-array-vertex ( x z -- vertex )
|
||||
[ terrain-vertex-distance first * ]
|
||||
[ terrain-vertex-distance second * ] bi*
|
||||
[ 0 ] dip float-array{ } 3sequence ;
|
||||
|
||||
: vertex-array-row ( z -- vertices )
|
||||
dup 1 + 2array
|
||||
terrain-vertex-size first 1 + iota
|
||||
2array [ first2 swap vertex-array-vertex ] product-map
|
||||
concat ;
|
||||
|
||||
: vertex-array ( -- vertices )
|
||||
terrain-vertex-size second iota
|
||||
[ vertex-array-row ] map concat ;
|
||||
|
||||
: >vertex-buffer ( bytes -- buffer )
|
||||
[ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
|
||||
|
||||
: draw-vertex-buffer-row ( i -- )
|
||||
[ GL_TRIANGLE_STRIP ] dip
|
||||
terrain-vertex-row-length * terrain-vertex-row-length
|
||||
glDrawArrays ;
|
||||
|
||||
: draw-vertex-buffer ( buffer -- )
|
||||
[ GL_ARRAY_BUFFER ] dip [
|
||||
3 GL_FLOAT 0 f glVertexPointer
|
||||
terrain-vertex-size second iota [ draw-vertex-buffer-row ] each
|
||||
] with-gl-buffer ;
|
||||
|
||||
: degrees ( deg -- rad )
|
||||
pi 180.0 / * ;
|
||||
|
||||
:: eye-rotate ( yaw pitch v -- v' )
|
||||
yaw degrees neg :> y
|
||||
pitch degrees neg :> p
|
||||
y cos :> cosy
|
||||
y sin :> siny
|
||||
p cos :> cosp
|
||||
p sin :> sinp
|
||||
|
||||
cosy 0.0 siny neg 3array
|
||||
siny sinp * cosp cosy sinp * 3array
|
||||
siny cosp * sinp neg cosy cosp * 3array 3array
|
||||
v swap v.m ;
|
||||
|
||||
: forward-vector ( world -- v )
|
||||
[ yaw>> ] [ pitch>> ] bi
|
||||
{ 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
|
||||
: rightward-vector ( world -- v )
|
||||
[ yaw>> ] [ pitch>> ] bi
|
||||
{ $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
|
||||
|
||||
: move-forward ( world -- )
|
||||
dup forward-vector [ v+ ] curry change-eye drop ;
|
||||
: move-backward ( world -- )
|
||||
dup forward-vector [ v- ] curry change-eye drop ;
|
||||
: move-leftward ( world -- )
|
||||
dup rightward-vector [ v- ] curry change-eye drop ;
|
||||
: move-rightward ( world -- )
|
||||
dup rightward-vector [ v+ ] curry change-eye drop ;
|
||||
|
||||
: rotate-with-mouse ( world mouse -- )
|
||||
[ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
|
||||
[ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi
|
||||
drop ;
|
||||
|
||||
:: handle-input ( world -- )
|
||||
read-keyboard keys>> :> keys
|
||||
key-w keys nth [ world move-forward ] when
|
||||
key-s keys nth [ world move-backward ] when
|
||||
key-a keys nth [ world move-leftward ] when
|
||||
key-d keys nth [ world move-rightward ] when
|
||||
world read-mouse rotate-with-mouse
|
||||
reset-mouse ;
|
||||
|
||||
M: terrain-world tick*
|
||||
[ handle-input ] keep
|
||||
! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug
|
||||
drop ;
|
||||
|
||||
M: terrain-world draw*
|
||||
nip draw-world ;
|
||||
|
||||
: set-heightmap-texture-parameters ( texture -- )
|
||||
GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
|
||||
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ;
|
||||
|
||||
M: terrain-world begin-world
|
||||
"2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
|
||||
require-gl-version-or-extensions
|
||||
GL_DEPTH_TEST glEnable
|
||||
GL_TEXTURE_2D glEnable
|
||||
GL_VERTEX_ARRAY glEnableClientState
|
||||
0.5 0.5 0.5 1.0 glClearColor
|
||||
EYE-START >>eye
|
||||
0.0 >>yaw
|
||||
0.0 >>pitch
|
||||
<terrain> [ >>terrain ] keep
|
||||
{ 0 0 } terrain-segment [ >>terrain-segment ] keep
|
||||
make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture
|
||||
terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
|
||||
>>terrain-program
|
||||
vertex-array >vertex-buffer >>terrain-vertex-buffer
|
||||
TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
|
||||
reset-mouse
|
||||
drop ;
|
||||
|
||||
M: terrain-world end-world
|
||||
{
|
||||
[ game-loop>> stop-loop ]
|
||||
[ terrain-vertex-buffer>> delete-gl-buffer ]
|
||||
[ terrain-program>> delete-gl-program ]
|
||||
[ terrain-texture>> delete-texture ]
|
||||
} cleave ;
|
||||
|
||||
M: terrain-world resize-world
|
||||
GL_PROJECTION glMatrixMode
|
||||
glLoadIdentity
|
||||
dim>> [ [ 0 0 ] dip first2 glViewport ]
|
||||
[ frustum glFrustum ] bi ;
|
||||
|
||||
M: terrain-world draw-world*
|
||||
[ set-modelview-matrix ]
|
||||
[ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
|
||||
[ dup terrain-program>> [
|
||||
"heightmap" glGetUniformLocation 0 glUniform1i
|
||||
terrain-vertex-buffer>> draw-vertex-buffer
|
||||
] with-gl-program ]
|
||||
tri gl-error ;
|
||||
|
||||
M: terrain-world focusable-child* drop t ;
|
||||
M: terrain-world pref-dim* drop { 640 480 } ;
|
||||
|
||||
: terrain-window ( -- )
|
||||
[
|
||||
open-game-input
|
||||
f T{ world-attributes
|
||||
{ world-class terrain-world }
|
||||
{ title "Terrain" }
|
||||
{ pixel-format-attributes {
|
||||
windowed
|
||||
double-buffered
|
||||
T{ depth-bits { value 24 } }
|
||||
} }
|
||||
} open-window
|
||||
] with-ui ;
|
||||
|
|
@ -26,6 +26,9 @@ short-url "SHORT_URLS" {
|
|||
: random-url ( -- string )
|
||||
1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
|
||||
|
||||
: retry ( quot: ( -- ? ) n -- )
|
||||
swap [ drop ] prepose attempt-all ; inline
|
||||
|
||||
: insert-short-url ( short-url -- short-url )
|
||||
'[ _ dup random-url >>short insert-tuple ] 10 retry ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue