diff --git a/Nmakefile b/Nmakefile index fb265b27d8..310358a60b 100644 --- a/Nmakefile +++ b/Nmakefile @@ -1,10 +1,32 @@ -!IF !DEFINED(VERSION) -VERSION = version-missing +VERSION = 0.98 + +# 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 +!IF [rm git-describe.tmp] == 0 +!ENDIF !ENDIF -!IF !DEFINED(GIT_LABEL) -GIT_LABEL = git-label-missing +!IF [git rev-parse HEAD > git-id.tmp] == 0 +GIT_ID = \ +!INCLUDE +!IF [rm git-id.tmp] == 0 !ENDIF +!ENDIF + +!IF [git rev-parse --abbrev-ref HEAD > git-branch.tmp] == 0 +GIT_BRANCH = \ +!INCLUDE +!IF [rm git-branch.tmp] == 0 +!ENDIF +!ENDIF + +GIT_LABEL = $(GIT_DESCRIBE)-$(GIT_ID) !IF DEFINED(PLATFORM) diff --git a/build.cmd b/build.cmd index 0ba6ede3cb..757bf45f37 100644 --- a/build.cmd +++ b/build.cmd @@ -1,10 +1,11 @@ @echo off setlocal -: Fun syntax -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 +: Check which branch we are on, or just assume master if we are not in a git repository for /f %%z in ('git rev-parse --abbrev-ref HEAD') do set GIT_BRANCH=%%z +if %GIT_BRANCH% =="" ( + GIT_BRANCH = "master" +) if "%1"=="/?" ( goto usage @@ -34,9 +35,6 @@ if not errorlevel 1 ( ) else goto nocl ) -set git_label=%GIT_DESCRIBE%-%GIT_ID% -set version=0.98 - echo Deleting staging images from temp/... del temp\staging.*.image diff --git a/extra/crontab/authors.txt b/extra/crontab/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/crontab/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/crontab/crontab-tests.factor b/extra/crontab/crontab-tests.factor new file mode 100644 index 0000000000..e0ba8d6dea --- /dev/null +++ b/extra/crontab/crontab-tests.factor @@ -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 diff --git a/extra/crontab/crontab.factor b/extra/crontab/crontab.factor new file mode 100644 index 0000000000..c214cec8fb --- /dev/null +++ b/extra/crontab/crontab.factor @@ -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 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 ; diff --git a/extra/crontab/summary.txt b/extra/crontab/summary.txt new file mode 100644 index 0000000000..c754345ba1 --- /dev/null +++ b/extra/crontab/summary.txt @@ -0,0 +1 @@ +Parser for crontab files diff --git a/extra/game-of-life/authors.txt b/extra/game-of-life/authors.txt new file mode 100644 index 0000000000..e091bb8164 --- /dev/null +++ b/extra/game-of-life/authors.txt @@ -0,0 +1 @@ +John Benediktsson diff --git a/extra/game-of-life/game-of-life.factor b/extra/game-of-life/game-of-life.factor new file mode 100644 index 0000000000..5bf48e1151 --- /dev/null +++ b/extra/game-of-life/game-of-life.factor @@ -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 ) + '[ _ ] 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 [| j | + cols [| 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 new + swap >>grid + 20 >>size + dup '[ _ [ grid>> next-step ] [ relayout-1 ] bi ] + f 1/5 seconds >>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 [| j | + cols new-cols min [| 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 ; + +: ( -- gadget ) + vertical life-gadget new-track + 20 20 make-grid + [ format-toolbar f track-add ] + [ 1 track-add ] bi ; + +M: life-gadget focusable-child* children>> second ; + +MAIN-WINDOW: life-window { + { title "Game of Life" } + } >>gadgets ; diff --git a/extra/game-of-life/summary.txt b/extra/game-of-life/summary.txt new file mode 100644 index 0000000000..78cc607252 --- /dev/null +++ b/extra/game-of-life/summary.txt @@ -0,0 +1 @@ +Conway's Game of Life diff --git a/extra/game-of-life/tags.txt b/extra/game-of-life/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/game-of-life/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/minesweeper/minesweeper.factor b/extra/minesweeper/minesweeper.factor index 39acfe46df..d62846d340 100644 --- a/extra/minesweeper/minesweeper.factor +++ b/extra/minesweeper/minesweeper.factor @@ -45,17 +45,16 @@ TUPLE: cell #adjacent mined? state ; : place-mines ( cells n -- cells ) [ dup unmined-cell t >>mined? drop ] times ; -: adjacent-mines ( cells row col -- #mines ) - neighbors [ - first2 [ + ] bi-curry@ bi* cell-at - [ mined?>> ] [ f ] if* - ] with with with count ; +:: count-neighbors ( cells row col quot: ( cell -- ? ) -- n ) + cells neighbors [ + first2 [ row + ] [ col + ] bi* cell-at quot [ f ] if* + ] with count ; inline -: adjacent-flags ( cells row col -- #mines ) - neighbors [ - first2 [ + ] bi-curry@ bi* cell-at - [ state>> +flagged+ = ] [ f ] if* - ] with with with count ; +: adjacent-mines ( cells row col -- #mines ) + [ mined?>> ] count-neighbors ; + +: adjacent-flags ( cells row col -- #flags ) + [ state>> +flagged+ = ] count-neighbors ; :: each-cell ( ... cells quot: ( ... row col cell -- ... ) -- ... ) cells |[ row | @@ -253,6 +252,19 @@ M: grid-gadget draw-gadget* [ draw-cells ] } 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 -- ) gadget hand-rel first2 :> ( w h ) h 58 < [ @@ -261,42 +273,11 @@ M: grid-gadget draw-gadget* gadget [ reset-cells ] change-cells f >>start f >>end drop ] when - ] [ - 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 ; + ] when gadget [ click-cell-at ] on-grid ; -:: on-mark ( gadget -- ) - 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-mark ( gadget -- ) [ mark-cell-at ] on-grid ; -:: on-open ( gadget -- ) - 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 ; +: on-open ( gadget -- ) [ open-cell-at ] on-grid ; : new-game ( gadget rows cols mines -- ) [ make-cells ] dip place-mines update-counts >>cells