Red [

Title: "Red control functions"

Author: "Gregg Irwin"

File: %control.red

Tabs: 4

; Rights: "Copyright (C) 2013 All Mankind. All rights reserved."

; License: {

; Distributed under the Boost Software License, Version 1.0.

; See https://github.com/dockimbel/Red/blob/master/BSL-License.txt

; }

]

; Evidence Oriented Programming

; `If and 'when are good words. 'case is not

; 'repeat and 'loop are good. 'for, 'foreach, and 'while are not.

; Specific word choices and ordering matter. Natural language isn't better.

; 'text vs 'string is just shorter and easier to type.

; repeat 'word value body ; current syntax

; repeat <n> times ... end

; repeat while <test> ... end

; repeat until <test> ... end

; repeat [n times]

; repeat [while test]

; repeat [until test]

; repeat-while test

; repeat/while body test

; Trying to fit into existing call syntax is ugly, because 'word is

; redundant for while/until, though it does give you auto-incrementing.

; The trick is to make it both clear and concise, because looping is

; used so often. We want it to be quick to read and understand, and

; easy to write correctly, without having to increment counters manually.

; A macro could easy transitioning.

repeat : function [

"Evaluates body a number of times, tracking iteration count."

'word [word!] "Iteration counter; not local to loop."

cond [integer! block!] "Iteration count or test condition."

body [block!]

/while "Evaluates body while condition block holds true."

/until "Evaluates body while condition block holds false."

][

; Using standard funcs while experimenting means hacking args.

if any [while until][

incr-word: reduce [to set-word! word word ' 1] ; add counter for while/until

set word 0 ; initialize it

body: head insert copy body incr-word ; increment it in the body

if until [append body cond] ; UNTIL tests at the end of the body

]

case [

while [system/words/while cond body]

until [system/words/until body]

'else [system/words/repeat :word cond body]

]

]

repeat i 3 [print ['n i]]

repeat /while i [i < 3] [print ['w i]]

repeat /until i [i >= 3] [print ['u i]]

; Ladislav's CFOR func

cfor: func [ ; Not this name

"General loop based on an initial state, test, and per-loop change."

init [block!] "Words and initial values as spec block (local)"

test [block!] "Continue if condition is true"

bump [block!] "Move to the next step in the loop"

body [block!] "Block to evaluate each time"

/local ret

] [

do function [] join init [

; It should actually make a selfless object from a block spec, but

; that's awkward to specify in mezzanine code, so just make sure

; that the native code makes a selfless context. It is likely a bad

; idea to catch any break or continue in the init evaluation code

; since the loop hasn't started yet, so we might want to just send

; them upwards. Or should we process break and ignore continue?

test: bind/copy test init

body: bind/copy body init

bump: bind/copy bump init

; We don't need a direct reference to init anymore here, but we will

; need to make sure our new values are referenced on the stack for

; safety in the native so they don't get collected. Those assignments

; are metaphors for replacing the references to the blocks in the stack

; frame slots with references to their copies.

while test [set/any 'ret do body do bump get/any 'ret]

; The body and bump should be evaluated separately to make sure their

; code doesn't mix, or otherwise you'll get weird errors. And don't

; forget to return the value from the evaluation of the body by default

; but also process break and continue from body, test and bump, according

; to the behavior of the while loop here.

]

]

; match - pattern matching SWITCH

; could also support various dispatch checkers to work like

; any of SWITCH, CASE, LIKE?, or SELECT-CASE.

; Pattern matching would be like tuplespace matching templates

res: match value [

_like? [...] []

_is? ! | [] []

:func []

? ! | [] []

]

binding-parse: function [input rules words [block!]][

?: [set v any-type! (set words/1 v words: next words)]

parse input bind/copy rules '?

head words

]

x: y: none

print binding-parse [1 2 a b] [integer! ? ? word!] [x y]

o: object [xx: yy: none]

print binding-parse [1 2 a b] [integer! ? ? word!] words-of o

; We want to parse 'input with 'rules, but we want to mod 'rules

; with the values that match '?

;unifying-parse: function [input rules "(modified)" words [block!]][

; ?: [set v any-type! (set words/1 v words: next words)]

; parse input bind/copy rules '?

; rules

;]

;x: y: none

;print binding-parse [1 2 a b] [integer! ? ? word!] [x y]

forskip: function [

"Evaluates a block at intervals in a series"

;[throw catch]

'word [word!] "Word set to each position in series (must refer to a series)"

size [integer!] "Number of values to skip each time"

body [block!] "Block to evaluate each time"

][

if not positive? size [cause-error 'script 'invalid-arg [size]]

if not [series? get word] [

cause-error 'script 'invalid-arg ["forskip expected word argument to refer to a series"]

]

orig: get word

; This test is a little tricky at a glance. ANY will be satisified until

; we hit the tail of the series. On each pass we move towards the tail.

; Once we hit the tail, ANY will evaluate the paren in the test, which

; resets the word to the original position in the series and returns

; false, which causes WHILE to break.

while [any [not tail? get word (set word orig false)]][

set/any 'result do body

set word skip get word size

get/any 'result

]

]

;b: [1 2 3 4 5 6]

;forskip b 0 [print [b/1 b/2]]

;forskip b 1 [print [b/1 b/2]]

;forskip b 2 [print [b/1 b/2]]

;forskip b 3 [print [b/1 b/2 b/3]]

;forskip b 4 [print [b/1 b/2 b/3 b/4]]

;forskip b 4 [print [b/1 b/2 break b/3 b/4]]

;-------------------------------------------------------------------------------

divisible?: func [a b] [0 = remainder a b]

; This doesn't work like R3 in how negative widths work.

forskip: func [

"Evaluates a block at regular intervals in a series."

'word [word!] "Word referring to the series to traverse (modified)"

width [integer!] "Interval size (width of each skip)"

body [block!] "Body to evaluate at each position"

/local orig result op

][

either zero? width [none] [

; Assert that word ref's series

if not [series? get word] [

cause-error 'script 'invalid-arg ["forskip expected word argument to refer to a series"]

]

; Store original position in series, so we can restore it.

orig: get word

; What is our "reached the end" test?

op: either positive? width [:tail?][:head?]

if all [negative? width tail? get word][

; We got a negative width, so we're going backwards,

; and we're at the tail. That means we want to step

; back one interval to find the start of the first

; "record".

set word skip get word width

]

; When we hit the end, restore the word to the original position.

while [any [not op get word (set word orig false)]][

set/any 'result do body

set word skip get word width

get/any 'result

]

if all [

negative? width

divisible? subtract index? orig 1 width

;?? check orig = get word for BREAK support?

][

; We got a negative width, so we're going backwards,

; and the above WHILE loop ended before processing

; the element at the head of the series. Plus we reset

; the word to its original position, *and* we would

; have landed right on the head. Because of all that,

; we want to process the head element.

set word head get word

set/any 'result do body

set word orig

]

get/any 'result

]

]

;tbb: back tb: tail blk: [1 2 3 4 5 6]

;forskip blk 2 [print mold blk]

;forskip tb -2 [print mold tb]

;forskip tbb -2 [print mold tbb]

;-------------------------------------------------------------------------------

opt: func [

"If condition is TRUE, return value, otherwise return empty value of the same type"

condition

value "Some types, e.g., word types, return none if condition is false."

][

either condition [:value][attempt [make :value 0]]

]

;opt true 'a

;opt true "A"

;opt false 'a

;opt false "test"

;opt false 100

;opt false http://www.red-lang.org

;opt false 10x10

;opt false 1:2:3

;

; select-case

;-------------------------------------------------------------------------------

; List Comprehension (Steeve, inspired by MaxV's Rebol version)

make-list-comprehension: function [rule][

parse rule [

some [

s: word! 'in skip

(in: last reduce/into ['foreach s/1 s/3 make block! 4] in)

| 'if skip

(in: last reduce/into ['if to-paren s/2 make block! 4] in)

| skip '|

(res: s/1 fun: in: make block! 4)

| (reduce/into ['reduce/into res 'tail 'out] in) break

]

]

has [out] compose [out: make block! 10 (fun) out]

]

;x-set: [1 2 3]

;r: make-list-comprehension [[x y ] | x in x-set y in [10 100 1000] if [ x <> 2]]

;r

;== func [/local out][out: make block! 10 foreach x x-set [foreach y [10 100 1000] [if (x <> 2) [reduce/into [x y] tail out]]] out]

;-------------------------------------------------------------------------------

match: func [

value

cases [block!]

;/only

][

]

; Is there a single, base func that can iterate, optionally with a skip

; value > 1, APPLY a function to values in the current "processing window"

; (MAP has a window size of 1), give that function all the info it needs

; to make detailed decisions (e.g. skip size). Maybe even throw in some

; pattern matching to make it interesting. You can build MAP from FOLD/

; ACCUMULATE, and a map func that returns NONE for some args can lead to

; an easy FILTER. So it's really a smart FOLD/ACCUMULATE (maybe with

; /reverse, like SORT, to become FOLDR), with an optional skip value. But

; the skip value may be mutiple words, like you would use with FOREACH,

; except that we really want this to be PARSE-based for maximum power.

mapskiply: func [

result "Where to collect output"

input [series!] "Series to iterate over"

rules [block!]

fn [any-function!]

/skip

size [integer!] ; could we also skip by typeset or rule?

][

]

blk: [a b c 1 2 3]

; MAP

res: mapskiply copy [] blk :append

;-------------------------------------------------------------------------------

do-in-parallel: func [progs [block!] "key-val pairs"][

while [not empty? progs][

foreach [key prog] progs [

do/next prog 'prog

progs/:key: prog

if empty? prog [remove/part find progs key 2]

]

]

]

do-in-parallel [

a [print 1 print 2 print 3]

b [ print "^-v" print "^-w" print "^-x" print "^-y" print "^-z"]

c [print [tab tab mold #qrs] print [tab tab now/time]]

]

;-------------------------------------------------------------------------------

do-tasks-in-parallel: function [tasks [block!] "Task objects"][

orig-list: tasks

tasks: copy tasks

while [not empty? tasks][

forall tasks [

task: tasks/1

task/_state: do/next task/_prog 'prog

task/_prog: prog

if task/_state = 'done [remove tasks]

]

head tasks

]

orig-list

]

task-proto: context [_prog: none _state: none]

make-task: func [spec body][

task: make task-proto spec

task/_prog: bind body task

task

]

t-a: make-task [a: 1 b: 2][

a: a 1 print a * b

a: a 1 print a * b

a: a 1 print a * b

'done

]

t-b: make-task [s: copy "" c: 'x][

append s c print mold s

append s c print mold s

append s c print mold s

append s c print mold s

append s c print mold s

'done

]

print mold do-tasks-in-parallel reduce [t-a t-b]

;-------------------------------------------------------------------------------

; match-case is a function that takes a set of conditions and dispatches,

; like CASE, by matching the result of all those conditions. The goal

; being to make what might take nested any/all constructs easier to read

; and branch on.

a: -1

b: 20

c: ""

match-case [

positive? a

b > 10

empty? c

][

[false false false] [none]

[false false true] [neg small empty]

[false true true] [neg big empty]

[true true true] [pos big empty]

[true true false] [pos big not-empty]

]

;-------------------------------------------------------------------------------

every: func [size value body /local interval] [

if zero? value // size [

interval: value / size

do bind/copy body 'interval

]

]

comment {

repeat i 50 [every 5 i [print [i interval]]]

}

; Another approach to `every` would be like Icon does, making it more like a

; HOF iterator

;-------------------------------------------------------------------------------

for-map: function [

"Iterate over a map, making each `key` and `value` available to the body."

data [map! series!]

body [block!]

][

either series? data [

foreach [key value] data [do body]

][

foreach key keys-of data [

value: data/:key

do bind body 'key

]

]

]

blk: [a: 1 b: 2 c: 3]

for-map m [print [key value]]

m: #(a: 11 b: 22 c: 33)

for-map m [print [key value]]

for-map m [

print [key value]

if value > 2 [break]

]

;-------------------------------------------------------------------------------

>> either': func [cond tv fv] [either cond [tv] [fv]]

== func [cond tv fv][either cond [tv] [fv]]

>> either' true 1 2

== 1

>> either' false 1 2

== 2

>> either' false [1] [2]

== [2]

; @toomasv

either': func [cond tv fv][

any [

block? tv: get pick [tv fv] cond return :tv

]

do tv

]

if': func [cond tv][

either tv: if cond [:tv][

either block? :tv [do tv][:tv]

][]

]

rejoin ['This if' false " omits" " something"]

;== "This something"

rejoin ['This if' true " omits" " something"]

;== "This omits something"

;-------------------------------------------------------------------------------

; Generator replacement

; take a series and return each element

;-------------------------------------------------------------------------------

; Boris' idea

foreach [pos: x y] srs [..]