Merge remote-tracking branch 'origin' into modern-harvey2

modern-harvey2
Doug Coleman 2018-03-11 00:44:10 -06:00
commit e7cd3e3635
11 changed files with 399 additions and 54 deletions

View File

@ -1,10 +1,32 @@
!IF !DEFINED(VERSION) VERSION = 0.98
VERSION = version-missing
# Crazy hack to do shell commands
# We do it in Nmakefile because that way we don't have to invoke build through build.cmd
# and we can just do ``nmake /f Nmakefile x86-64-vista`` or similar
# and we still get the git branch, id, etc
!IF [git describe --all > git-describe.tmp] == 0
GIT_DESCRIBE = \
!INCLUDE <git-describe.tmp>
!IF [rm git-describe.tmp] == 0
!ENDIF
!ENDIF !ENDIF
!IF !DEFINED(GIT_LABEL) !IF [git rev-parse HEAD > git-id.tmp] == 0
GIT_LABEL = git-label-missing GIT_ID = \
!INCLUDE <git-id.tmp>
!IF [rm git-id.tmp] == 0
!ENDIF !ENDIF
!ENDIF
!IF [git rev-parse --abbrev-ref HEAD > git-branch.tmp] == 0
GIT_BRANCH = \
!INCLUDE <git-branch.tmp>
!IF [rm git-branch.tmp] == 0
!ENDIF
!ENDIF
GIT_LABEL = $(GIT_DESCRIBE)-$(GIT_ID)
!IF DEFINED(PLATFORM) !IF DEFINED(PLATFORM)

View File

@ -1,10 +1,11 @@
@echo off @echo off
setlocal setlocal
: Fun syntax : Check which branch we are on, or just assume master if we are not in a git repository
for /f %%x in ('git describe --all') do set GIT_DESCRIBE=%%x
for /f %%y in ('git rev-parse HEAD') do set GIT_ID=%%y
for /f %%z in ('git rev-parse --abbrev-ref HEAD') do set GIT_BRANCH=%%z for /f %%z in ('git rev-parse --abbrev-ref HEAD') do set GIT_BRANCH=%%z
if %GIT_BRANCH% =="" (
GIT_BRANCH = "master"
)
if "%1"=="/?" ( if "%1"=="/?" (
goto usage goto usage
@ -34,9 +35,6 @@ if not errorlevel 1 (
) else goto nocl ) else goto nocl
) )
set git_label=%GIT_DESCRIBE%-%GIT_ID%
set version=0.98
echo Deleting staging images from temp/... echo Deleting staging images from temp/...
del temp\staging.*.image del temp\staging.*.image

View File

@ -0,0 +1 @@
John Benediktsson

View File

@ -0,0 +1,22 @@
USING: calendar crontab kernel tools.test ;
{
T{ timestamp
{ year 2018 }
{ month 3 }
{ day 9 }
{ hour 12 }
{ minute 23 }
{ gmt-offset T{ duration { hour -8 } } }
}
} [
"23 0-20/2 * * *" parse-cronentry
T{ timestamp
{ year 2018 }
{ month 3 }
{ day 9 }
{ hour 12 }
{ minute 6 }
{ gmt-offset T{ duration { hour -8 } } }
} [ next-time-after ] keep
] unit-test

View File

@ -0,0 +1,104 @@
! Copyright (C) 2018 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays ascii assocs calendar calendar.english
calendar.private combinators io kernel literals locals math
math.order math.parser math.ranges sequences splitting ;
IN: crontab
:: parse-value ( value quot: ( value -- value' ) seq -- value )
value {
{ [ CHAR: , over member? ] [
"," split [ quot seq parse-value ] map concat ] }
{ [ dup "*" = ] [ drop seq ] }
{ [ CHAR: / over member? ] [
"/" split1 [ quot seq parse-value 0 over length 1 - ] dip
string>number <range> swap nths ] }
{ [ CHAR: - over member? ] [
"-" split1 quot bi@ [a,b] ] }
[ quot call 1array ]
} cond ; inline recursive
: parse-day ( str -- n )
dup string>number [ ] [
>lower $[ day-abbreviations3 [ >lower ] map ] index
] ?if ;
: parse-month ( str -- n )
dup string>number [ ] [
>lower $[ month-abbreviations [ >lower ] map ] index
] ?if ;
TUPLE: cronentry minutes hours days months days-of-week command ;
CONSTANT: aliases H{
{ "@yearly" "0 0 1 1 *" }
{ "@annually" "0 0 1 1 *" }
{ "@monthly" "0 0 1 * *" }
{ "@weekly" "0 0 * * 0" }
{ "@daily" "0 0 * * *" }
{ "@midnight" "0 0 * * *" }
{ "@hourly" "0 * * * *" }
}
: parse-cronentry ( entry -- cronentry )
" " split1 [ aliases ?at drop ] dip " " glue
" " split1 " " split1 " " split1 " " split1 " " split1 {
[ [ string>number ] T{ range f 0 60 1 } parse-value ]
[ [ string>number ] T{ range f 0 24 1 } parse-value ]
[ [ string>number ] T{ range f 0 31 1 } parse-value ]
[ [ parse-month ] T{ range f 0 12 1 } parse-value ]
[ [ parse-day ] T{ range f 0 7 1 } parse-value ]
[ ]
} spread cronentry boa ;
:: next-time-after ( cronentry timestamp -- )
timestamp month>> :> month
cronentry months>> [ month >= ] find nip [
dup month = [ drop f ] [ timestamp month<< t ] if
] [
timestamp cronentry months>> first >>month 1 +year
] if* [ cronentry timestamp next-time-after ] when
timestamp hour>> :> hour
cronentry hours>> [ hour >= ] find nip [
dup hour = [ drop f ] [
timestamp hour<< 0 timestamp minute<< t
] if
] [
timestamp cronentry hours>> first >>hour 1 +day
] if* [ cronentry timestamp next-time-after ] when
timestamp minute>> :> minute
cronentry minutes>> [ minute >= ] find nip [
dup minute = [ drop f ] [ timestamp minute<< t ] if
] [
timestamp cronentry minutes>> first >>minute 1 +hour
] if* [ cronentry timestamp next-time-after ] when
timestamp day-of-week :> weekday
cronentry days-of-week>> [ weekday >= ] find nip [
cronentry days-of-week>> first 7 +
] unless* weekday -
timestamp day>> :> day
cronentry days>> [ day >= ] find nip [
day -
] [
timestamp 1 months time+
cronentry days>> first >>day
day-of-year timestamp day-of-year -
] if*
min [
timestamp swap +day drop
cronentry timestamp next-time-after
] unless-zero ;
: next-time ( cronentry -- timestamp )
now 0 >>second [ next-time-after ] keep ;
: parse-crontab ( -- entries )
lines [ [ f ] [ parse-cronentry ] if-empty ] map harvest ;

View File

@ -0,0 +1 @@
Parser for crontab files

View File

@ -0,0 +1 @@
John Benediktsson

View File

@ -0,0 +1,213 @@
! Copyright (C) 2018 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays assocs bit-arrays calendar
colors.constants combinators combinators.short-circuit fry
kernel kernel.private locals math math.order math.private
math.ranges namespaces opengl random sequences sequences.private
timers ui ui.commands ui.gadgets ui.gadgets.toolbar
ui.gadgets.tracks ui.gestures ui.render words ;
IN: game-of-life
: make-grid ( rows cols -- grid )
'[ _ <bit-array> ] replicate ;
: grid-dim ( grid -- rows cols )
[ length ] [ first length ] bi ;
:: wraparound ( x min max -- y )
x min fixnum< [ max ] [ x max fixnum> min x ? ] if ; inline
:: count-neighbors ( grid -- counts )
grid grid-dim { fixnum fixnum } declare :> ( rows cols )
rows <iota> [| j |
cols <iota> [| i |
{ -1 0 1 } [
{ -1 0 1 } [
2dup [ 0 eq? ] both? [ 2drop f ] [
[ i fixnum+fast 0 cols 1 - wraparound ]
[ j fixnum+fast 0 rows 1 - wraparound ] bi*
{ fixnum fixnum } declare grid
{ array } declare nth-unsafe
{ bit-array } declare nth-unsafe
] if
] with count
] map-sum
] map
] map ;
:: next-step ( grid -- )
grid count-neighbors :> neighbors
grid [| row j |
row [| cell i |
i j neighbors
{ array } declare nth-unsafe
{ array } declare nth-unsafe
cell [
2 3 between? i j grid
{ array } declare nth-unsafe
{ bit-array } declare set-nth-unsafe
] [
3 = [
t i j grid
{ array } declare nth-unsafe
{ bit-array } declare set-nth-unsafe
] when
] if
] each-index
] each-index ;
TUPLE: grid-gadget < gadget grid size timer ;
: <grid-gadget> ( grid -- gadget )
grid-gadget new
swap >>grid
20 >>size
dup '[ _ [ grid>> next-step ] [ relayout-1 ] bi ]
f 1/5 seconds <timer> >>timer ;
M: grid-gadget ungraft*
[ timer>> stop-timer ] [ call-next-method ] bi ;
M: grid-gadget pref-dim*
[ grid>> grid-dim swap ] [ size>> '[ _ * ] bi@ 1 + 2array ] bi ;
:: update-grid ( gadget -- )
gadget dim>> first2 :> ( w h )
gadget size>> :> size
h w [ size /i ] bi@ :> ( new-rows new-cols )
gadget grid>> :> grid
grid grid-dim :> ( rows cols )
rows new-rows = not
cols new-cols = not or [
new-rows new-cols make-grid :> new-grid
rows new-rows min <iota> [| j |
cols new-cols min <iota> [| i |
i j grid nth nth
i j new-grid nth set-nth
] each
] each
new-grid gadget grid<<
] when ;
:: draw-cells ( gadget -- )
COLOR: black gl-color
gadget size>> :> size
gadget grid>> [| row j |
row [| cell i |
cell [
i j [ size * ] bi@ 2array
{ size size } gl-fill-rect
] when
] each-index
] each-index ;
:: draw-lines ( gadget -- )
gadget size>> :> size
gadget grid>> grid-dim :> ( rows cols )
COLOR: gray gl-color
cols rows [ size * ] bi@ :> ( w h )
rows [0,b] [| j |
j size * :> y
{ 0 y } { w y } gl-line
cols [0,b] [| i |
i size * :> x
{ x 0 } { x h } gl-line
] each
] each ;
M: grid-gadget draw-gadget*
[ update-grid ] [ draw-cells ] [ draw-lines ] tri ;
SYMBOL: last-click
:: on-click ( gadget -- )
gadget size>> :> size
gadget grid>> grid-dim :> ( rows cols )
gadget hand-rel first2 [ size /i ] bi@ :> ( i j )
i 0 cols 1 - between?
j 0 rows 1 - between? and [
i j gadget grid>> nth
[ not dup last-click set ] change-nth
] when gadget relayout-1 ;
:: on-drag ( gadget -- )
gadget size>> :> size
gadget grid>> grid-dim :> ( rows cols )
gadget hand-rel first2 [ size /i ] bi@ :> ( i j )
i 0 cols 1 - between?
j 0 rows 1 - between? and [
last-click get i j gadget grid>> nth set-nth
] when gadget relayout-1 ;
: on-scroll ( gadget -- )
[
scroll-direction get second {
{ [ dup 0 > ] [ -2 ] }
{ [ dup 0 < ] [ 2 ] }
[ 0 ]
} cond nip + 4 30 clamp
] change-size relayout-1 ;
:: com-play ( gadget -- )
gadget timer>> thread>> [
gadget timer>> start-timer
] unless ;
:: com-step ( gadget -- )
gadget grid>> next-step
gadget relayout-1 ;
:: com-stop ( gadget -- )
gadget timer>> thread>> [
gadget timer>> stop-timer
] when ;
:: com-clear ( gadget -- )
gadget grid>> [ clear-bits ] each
gadget relayout-1 ;
:: com-random ( gadget -- )
gadget grid>> [
[ length>> ] [ underlying>> length random-bytes ] bi
bit-array boa
] map! drop gadget relayout-1 ;
:: com-glider ( gadget -- )
gadget grid>> :> grid
{ { 2 1 } { 3 2 } { 1 3 } { 2 3 } { 3 3 } }
[ first2 grid nth t -rot set-nth ] each
gadget relayout-1 ;
grid-gadget "toolbar" f {
{ T{ key-down { sym "1" } } com-play }
{ T{ key-down { sym "2" } } com-stop }
{ T{ key-down { sym "3" } } com-clear }
{ T{ key-down { sym "4" } } com-random }
{ T{ key-down { sym "5" } } com-glider }
{ T{ key-down { sym "6" } } com-step }
} define-command-map
grid-gadget "gestures" [
{
{ T{ key-down f { A+ } "F" } [ toggle-fullscreen ] }
{ T{ button-down { # 1 } } [ on-click ] }
{ T{ drag { # 1 } } [ on-drag ] }
{ mouse-scroll [ on-scroll ] }
} assoc-union
] change-word-prop
TUPLE: life-gadget < track ;
: <life-gadget> ( -- gadget )
vertical life-gadget new-track
20 20 make-grid <grid-gadget>
[ <toolbar> format-toolbar f track-add ]
[ 1 track-add ] bi ;
M: life-gadget focusable-child* children>> second ;
MAIN-WINDOW: life-window {
{ title "Game of Life" }
} <life-gadget> >>gadgets ;

View File

@ -0,0 +1 @@
Conway's Game of Life

View File

@ -0,0 +1 @@
demos

View File

@ -45,17 +45,16 @@ TUPLE: cell #adjacent mined? state ;
: place-mines ( cells n -- cells ) : place-mines ( cells n -- cells )
[ dup unmined-cell t >>mined? drop ] times ; [ dup unmined-cell t >>mined? drop ] times ;
: adjacent-mines ( cells row col -- #mines ) :: count-neighbors ( cells row col quot: ( cell -- ? ) -- n )
neighbors [ cells neighbors [
first2 [ + ] bi-curry@ bi* cell-at first2 [ row + ] [ col + ] bi* cell-at quot [ f ] if*
[ mined?>> ] [ f ] if* ] with count ; inline
] with with with count ;
: adjacent-flags ( cells row col -- #mines ) : adjacent-mines ( cells row col -- #mines )
neighbors [ [ mined?>> ] count-neighbors ;
first2 [ + ] bi-curry@ bi* cell-at
[ state>> +flagged+ = ] [ f ] if* : adjacent-flags ( cells row col -- #flags )
] with with with count ; [ state>> +flagged+ = ] count-neighbors ;
:: each-cell ( ... cells quot: ( ... row col cell -- ... ) -- ... ) :: each-cell ( ... cells quot: ( ... row col cell -- ... ) -- ... )
cells |[ row | cells |[ row |
@ -253,6 +252,19 @@ M: grid-gadget draw-gadget*
[ draw-cells ] [ draw-cells ]
} cleave ; } cleave ;
:: on-grid ( gadget quot: ( cells row col -- ? ) -- )
gadget hand-rel first2 :> ( w h )
h 58 >= [
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> :> cells
cells game-over? [
cells row col quot call [
gadget start>> [ now gadget start<< ] unless
cells game-over? [ now gadget end<< ] when
] when
] unless
] when gadget relayout-1 ; inline
:: on-click ( gadget -- ) :: on-click ( gadget -- )
gadget hand-rel first2 :> ( w h ) gadget hand-rel first2 :> ( w h )
h 58 < [ h 58 < [
@ -261,42 +273,11 @@ M: grid-gadget draw-gadget*
gadget [ reset-cells ] change-cells gadget [ reset-cells ] change-cells
f >>start f >>end drop f >>start f >>end drop
] when ] when
] [ ] when gadget [ click-cell-at ] on-grid ;
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> :> cells
cells game-over? [
cells row col click-cell-at [
gadget start>> [ now gadget start<< ] unless
cells game-over? [ now gadget end<< ] when
] when
] unless
] if gadget relayout-1 ;
:: on-mark ( gadget -- ) : on-mark ( gadget -- ) [ mark-cell-at ] on-grid ;
gadget hand-rel first2 :> ( w h )
h 58 >= [
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> :> cells
cells game-over? [
cells row col mark-cell-at [
gadget start>> [ now gadget start<< ] unless
cells game-over? [ now gadget end<< ] when
] when
] unless
] when gadget relayout-1 ;
:: on-open ( gadget -- ) : on-open ( gadget -- ) [ open-cell-at ] on-grid ;
gadget hand-rel first2 :> ( w h )
h 58 >= [
h 58 - w [ 32 /i ] bi@ :> ( row col )
gadget cells>> :> cells
cells game-over? [
cells row col open-cell-at [
gadget start>> [ now gadget start<< ] unless
cells game-over? [ now gadget end<< ] when
] when
] unless
] when gadget relayout-1 ;
: new-game ( gadget rows cols mines -- ) : new-game ( gadget rows cols mines -- )
[ make-cells ] dip place-mines update-counts >>cells [ make-cells ] dip place-mines update-counts >>cells