__, Copyright 2012-2020 Dustin DeWeese

| This file is part of PoprC.

|

| PoprC is free software: you can redistribute it and/or modify

| it under the terms of the GNU General Public License as published by

| the Free Software Foundation, either version 3 of the License, or

| (at your option) any later version.

|

| PoprC is distributed in the hope that it will be useful,

| but WITHOUT ANY WARRANTY; without even the implied warranty of

| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

| GNU General Public License for more details.

|

| You should have received a copy of the GNU General Public License

| along with PoprC. If not, see <http://www.gnu.org/licenses/>.

|______________________________________________________________________

module lib:

imports:

module num

module list

module stack

module control

module num:

imports:

module stack

module control

__ max of two values

max: [] ap20 dup . dup tail | [<= !] . popr nip

__ min of two values

min: [] ap20 dup . dup tail | [> !] . popr nip

__ is argument odd?

odd: 1 &b 1 ==

even: 1 &b 0 ==

bound: [dup_under >= !] dip21 dup_under <= !

up_to: 0 swap bound

module list:

imports:

module control

module stack

module logic

__ take rightmost value from quote

head: popr nip

top: dup head

__ return the length of a list

length:

[0 swap] pushl

[[[1 ] [tail] para] .]

[popr popr valid]

iterate tail head

__ right fold

__ [... x] y [fn] foldr -> y'

foldr:

[-swap2] ap30 __ fn xs y

[[foldr_step] .]

[tail head popr valid]

iterate head

foldr_step: [popr] dip12 over3 ap21 nip

__ left fold

__ [... x] y [fn] foldl -> y'

foldl:

swap2 [[]] ap20 __ fn xs y

[[foldl_step] .]

[popr drop head popr valid]

iterate head ap11 nip

foldl_step: [popr over2 pushl] dip23 .

dropl:

[] ap20

[[[tail] [1-] para] .]

[head 0 >]

iterate tail head

__ [a.. x] [b..] -> [a..] [x b..]

movr: [popr] dip12 pushl

__ not working

__ split_at: [[[]] pushl] dip11 [[movr] .] swap times ap02 swap2 drop

split_at:

[[] swap] ap20

[[[movr] dip22 1-] .]

[head 0 >]

iterate tail get2

__ index operator

__ [f] index -> x

@: dropl head

__ a [a -> a] -> [a]

iteratel: dup [peek] dip22 [iteratel] $$ swap pushr

__ a [f] -> [... a f f f a f f a f a]

itercat: dup_under itercat_loop swap pushr

itercat_loop: dup [itercat_loop] pushl [pushl dup head] dip22 $ swap .

concat: [] [.] foldr

__ [xs] [f] map -> [xs']

map:

[popr dup [seq] pushl] dip13 __ [xs] x [x seq] [f]

dup [swap . pushl] dip31 __ [xs] [x f*] [f] (* = x seq)

[map] pushl swap __ [xs] [[f] map] [x f*]

[$] dip21 . __ [[xs] [f] map . x f*]

__ [xs] s [f] map_with -> [xs']

map_with:

[[popr] dip12 swap] dip23 __ [xs] s x [f]

dup [$$-] dip32 swap __ [xs] s' [f] x'

[map_with] dip31 pushr

__ a [b..] [p] pushif

__ a p ==> [a b..]

__ otherwise ==> [b..]

pushif:

[over] dip23 $

-swap2 dup [pushl] dip21

ifte

__ [..x] [f] $top -> [..x] [f] xf

$top: dup2 . head

__ [l] [p] next_match -> [l'] x

next_match:

$top [nip [popr] dip12 !!]

[[[tail] dip11 next_match] dip22 not!!] | $$$-

__ [l] [p] filter -> [..x..] such that for all x, x p == True

filter: tuck next_match [swap filter] dip21 pushr

__ second implementation that fuses after map

__ TODO remove need for this

filter2:

[popr] dip12 tuck peek []ap20 __ [...] [fn] [x fx]

[filter2] dip21

[[pushr] dip21 !]

[[drop] dip21 not!] | . $

__ a n listdup --> [a... x n]

listdup: [] -swap2 [swap pushl] pushl swap times

reverse: [] [swap pushr] foldr

__ [... a] [... b] pop_par --> [...] [...] a b

pop_par: [popr] dip12 popr [swap] dip22

top_par: [top] dip12 top [swap] dip22

__ pop the smaller integer from two lists

__ NOTE why does this compile slow?

pop_min:

[top_par <=] ap20

[[[popr] dip12 swap] dip23] __ a <= b

[[popr] dip12 not] | . popr! get3 __ a > b

pushl_seq: over seq pushl

pushl_seq2: pushl_seq pushl_seq

__ [a] [b] [acc]

merge_step: [pop_min] dip23 pushl_seq

__ [a] [b] [acc]

merge_loop:

[] ap30 dup

[] [[swap] dip22] | . __ [[a] [b] [acc]] | [[b] [a] [acc]]

[. [head] dip11 otherwise] . swap

[merge_step merge_loop] . | head

merge: [] merge_loop

half_rem: dup 2/ dup [-] dip21

_[ broken

__ split_list: [half_rem [dup [split_at] dip22] dip23 -swap2 []ap20 [[] ap20] dip21]. get2

split_list: half_rem [dup [split_at] dip22] dip23 -swap2

sort:

dup length []ap20

[get2 dup [split_list []ap20 [[]ap20] dip21] dip22 1 > !!] __ split

[tail head] __ strip off the length

[merge] __ combine

bitree

]_

split_list: dup length dup [2/ split_at] dip22

seq_list: dup True [seq] foldr seq

sort:

[split_list 1 > !!] __ split

[] __ transform

[merge seq_list _hack_ ] __ combine

bitree

__ [list] key

assoc_step: [popr get2] dip13 =s

assoc:

tuck assoc_step

[!]

[[drop swap assoc] dip31 not!] | ap41 nip

__ remove: [head] swap [=s not] pushl . filter

repeat: dup [repeat]$ swap pushr

__ [... a] [... b] popr_para -> [...] [...] a b

popr_para: [popr] dip12 popr [swap] dip22

__ [... a] [... b] [f] zip1 -> [...] [...] [f] [a b f]

zip1: [popr_para] dip24 dup -swap3 pushl_seq2

__ [... a] [... b] [f] zip -> [... f a b f]

zip: [zip1] ap31 [zip] swap [. head] dip21 .

__ [... a] [... b] c [f] zip1_with -> [...] [...] c' [f] [f']

zip1_with: [[popr_para] dip24] dip35 dup -swap4 ap31 -swap2

__ [... a] [... b] c [f] zip_with -> [... c' f a b c f]

zip_with: [zip1_with] ap41 [zip_with] swap [. head] dip21 .

__ [... [a b]] unzip -> [... a] [... b]

unzip: dup [popr drop head] map swap [head] map

__ split interleaved streams marked with Left/Right

__ [[..., xl Left, xr Right]] -> [... xl] [... xr]

unzip_either:

[[head Left =:=] filter,

[head Right =:=] filter] fork

[[popr drop head] map] both

pushq: [[]ap10] swap . ap10

pushq2: [[]ap20] swap . ap20

pushq3: [[]ap30] swap . ap30

pushq4: [[]ap40] swap . ap40

pushq5: [[]ap50] swap . ap50

pushq6: [[]ap60] swap . ap60

pushq7: [[]ap70] swap . ap70

pick:

[popr]

[swap popr [swap] dip22] | $$--

pick_either:

[popr [Right] pushl]

[swap popr [Left] pushl [swap] dip22] | $$--

interleave: pick -swap2 [interleave] $$ swap pushr

__ [[fa]] [[fb]] c -> [fa fb | ...]

interleave_with:

[pick] dip23 swap $-seq __ [a] [b] c0' c1'

[interleave_with] dip31 dup [pushr] dip21 seq

interleave_with2:

[[[[].] map,

[[interleave_apply_right].] map] para] dip22 interleave_with

[] [swap .] foldr

__ [l] [r] a [f] -> [l fa] [r] a' (left), [l] [r fa] a' (right)

interleave_apply_left: $-seq [swap2] dip33 pushr -swap2

interleave_apply_right: $-seq [swap] dip22 pushr swap

__ [l] [r] x Left/Right -> [l x] [r] / [l] [r x]

either_push:

[Left =:= [[swap] dip22 pushr swap] dip32 !!]

[Right =:= [pushr] dip21 !!] | $$$$-

module stack:

imports:

module control

__ [x_1 ... x_n] -> x_n ... x_1 []

pull: popr swap

pull2: pull pull

pull3: pull2 pull

pull4: pull3 pull

pull5: pull4 pull

pull6: pull5 pull

pull7: pull6 pull

pull8: pull7 pull

get2: ap02 swap2 drop

get3: ap03 swap3 drop

get4: ap04 swap4 drop

get5: ap05 swap5 drop

get6: ap06 swap6 drop

get7: ap07 swap7 drop

tail: popr drop

tail2: tail tail

rev3: [] ap30 pull3 drop

__ a b -> b

nip: swap drop

nip2: swap2 drop

nip3: swap3 drop

__ a b -> b a b

tuck: [] ap20 dup . pull3 drop

__ a b -> a b a

over: swap dup [swap] dip22

over2: swap2 dup [-swap2] dip33

over3: swap3 dup [-swap3] dip44

over4: swap4 dup [-swap4] dip55

dup2: [] ap20 dup . ap04 swap4 drop

dup_under: [dup] dip12

__ x_1 x_2 ... x_n -> x_2 ... x_n x_1

swap2: [] swap pushr swap pushr pushl pull3 drop

swap3: [] swap pushr swap pushr swap pushr pushl pull4 drop

swap4: [] swap pushr swap pushr swap pushr swap pushr pushl pull5 drop

swap5: [] swap pushr swap pushr swap pushr swap pushr swap pushr pushl pull6 drop

swap6: [] swap pushr swap pushr swap pushr swap pushr swap pushr swap pushr pushl pull7 drop

swap7: [] swap pushr swap pushr swap pushr swap pushr swap pushr swap pushr swap pushr pushl pull8 drop

__ x_2 ... x_n x_1 -> x_1 x_2 ... x_n

-swap2: swap2 swap2

-swap3: swap3 swap3 swap3

-swap4: swap4 swap4 swap4 swap4

-swap5: swap5 swap5 swap5 swap5 swap5

-swap6: swap6 swap6 swap6 swap6 swap6 swap6

exch2: swap2 swap -swap2

exch3: swap3 swap -swap3

exch4: swap4 swap -swap4

module control:

imports:

module stack

module logic

module list

__ if then else

ifte: [] ap20 swap pushr [not!] [nip!] | . head

__ ifte2: rot [swap drop 0 != !] [0 == !] | pushl pushl pushl popr swap drop cut

__ apply a quote underneath the top

dip11: swap pushr ap12 swap2 drop

dip12: swap pushr ap13 swap3 drop

dip13: swap pushr ap14 swap4 drop

dip14: swap pushr ap15 swap5 drop

dip15: swap pushr ap16 swap6 drop

dip16: swap pushr ap17 swap7 drop

dip21: swap pushr ap22 swap2 drop

dip22: swap pushr ap23 swap3 drop

dip23: swap pushr ap24 swap4 drop

dip24: swap pushr ap25 swap5 drop

dip25: swap pushr ap26 swap6 drop

dip26: swap pushr ap27 swap7 drop

dip31: swap pushr ap32 swap2 drop

dip32: swap pushr ap33 swap3 drop

dip33: swap pushr ap34 swap4 drop

dip34: swap pushr ap35 swap5 drop

dip35: swap pushr ap36 swap6 drop

dip36: swap pushr ap37 swap7 drop

dip41: swap pushr ap42 swap2 drop

dip42: swap pushr ap43 swap3 drop

dip43: swap pushr ap44 swap4 drop

dip44: swap pushr ap45 swap5 drop

dip45: swap pushr ap46 swap6 drop

dip46: swap pushr ap47 swap7 drop

dip51: swap pushr ap52 swap2 drop

dip52: swap pushr ap53 swap3 drop

dip53: swap pushr ap54 swap4 drop

dip54: swap pushr ap55 swap5 drop

dip55: swap pushr ap56 swap6 drop

dip56: swap pushr ap57 swap7 drop

dip61: swap pushr ap62 swap2 drop

dip62: swap pushr ap63 swap3 drop

dip63: swap pushr ap64 swap4 drop

dip64: swap pushr ap65 swap5 drop

dip65: swap pushr ap66 swap6 drop

dip66: swap pushr ap67 swap7 drop

__ a [f] -> fa

$: ap11 nip

$$: ap21 nip

$$$: ap31 nip

$$$$: ap41 nip

$-: ap12 nip2

$$-: ap22 nip2

$$$-: ap32 nip2

$$$$-: ap42 nip2

$--: ap13 nip3

$$--: ap23 nip3

$$$--: ap33 nip3

$$$$--: ap43 nip3

$seq: [dup] dip12 $ swap seq

$-seq: [dup] dip12 $- swap2 seq2

__ a [f] -> fa [f]

$keep: dup [$] dip21

$$keep: dup [$$] dip31

$$$keep: dup [$$$] dip41

$-keep: dup [$-] dip22

$$-keep: dup [$$-] dip32

$$$-keep: dup [$$$-] dip42

__ apply a quote underneath N items to extract something

__ a b c ... [f] withN -> fa0 b c ... fa1

with2: dip12 swap

with3: [with2] pushl dip23 swap

with4: [with3] pushl dip34 swap

with5: [with4] pushl dip45 swap

with6: [with5] pushl dip56 swap

__ a [f] -> a fa

peek: dup_under $

__ [a] [f] -> [a] [a f]

peek_cmp: dup_under .

__ a [f] -> fa a

->: peek swap

->cmp: peek_cmp swap

__ a [f] [g] -> fa ga

fork: [->] dip22 $

fork_cmp: [->cmp] dip22 .

__ a [f] [g] [h] -> fa ga ha

fork3: [[->] dip22 ->] dip33 $

fork_cmp3: [[->cmp] dip22 ->cmp] dip33 .

__ a b [f] [g] -> fa gb

para: [dip11] dip32 $

__ a b [f] -> fa fb

both: dup para

__ a [cond] [f] -> fa

__ f fails if cond does not return True

if: [peek] dip22 swap [$] dip21 !

__ a [f b] -> fa if b, otherwise a

ifdo: dup [dup] swap . [[drop] dip21 not] . | ap12 swap2 drop !

__ a b -> a b [a b]

in2: [] ap20 dup [get2] dip12

in3: [] ap30 dup [get3] dip13

__ a [fn] [test] -> apply fn to a while a [test] $ is True

iterate:

in2 [iterate] . __ a [fn] [test] [[fn] [test] iterate]

[swap] dip22 . swap __ a [fn [fn] [test] iterate] [test]

[fork] ap20 ifdo

while:

over [$keep dup_under while] dip22 vifte

__ apply [f] n times

times: __ a [f] n

[] ap30

[[times_step] .]

[head 0 >]

iterate tail2 head

times_step: [$keep] dip22 1-

__ m [f] a -> a

maybe:

rev3 __ a [f] m

[[drop] dip21 Nothing =:= !]

[Just =:= ! swap $] | . $$

__ e [f1] [f2] -> a

either:

[Right =:= !] swap . swap

[Left =:= !] swap . | . head

!!: [[] ap20] dip21! get2

!!!: [[] ap30] dip31! get3

__ x [split] [f] [combine] diamond -> x'

__ .-> f -.

__ x -> split -< >-> combine -> x'

__ '-> f -'

diamond: [[$-] dip22 both] dip32 $$

__ x [split] [f] [combine] bitree -> x'

bitree:

over3 over2 $ __ f x -> x'

[in3 [bitree]. quote dip11 diamond] dip41 __ diamond bitree

default

seq2: [[]ap20] dip21 seq get2

__ feed x as an input to each quote and compose them

__ this is the reader monad

__ [ ... , ... ] [x] scatter1 ---> [ ... x ... ]

__ [x] [[ ... , ... , ...]] scatter ---> [ x ... x ... x ... ]

scatter1: [swap .] pushl dip11 .

scatter: swap [scatter1] pushl [] swap foldr __ rename to splice?

__ extract values

__ this is the writer monad

__ [[ ... x, ... y, ... ]] gather ---> [ ... ... ... ] [x y]

gather1: . pull [pushr] dip21

gather_r:

[[] []] [swap pushr [gather1] .] foldr get2

gather: reverse gather_r

__ these don't work yet:

__ gather: [[] []] [pushr [gather1] .] foldl get2

__ gather:

__ [] [[gather1] swap . pushl] foldr

__ [] [] swap2 $$-

module logic:

imports:

module stack

module control

or: [not!] [True swap!] | ap21 nip symbol_t

and: [!] [False swap not!] | ap21 nip symbol_t

implies: swap not or

__ A B default -> A, or B if A fails

default: dup_under otherwise |

otherwise2: __ a0 a1 b0 b1

[] ap20 otherwise otherwise get2

vifte: [swap] dip22 otherwise dup swap2 otherwise |

valid: True False vifte

___ A A B other -> B, B A B other -> A

other: [] [swap] | [[=:=] dip21 swap!] . $$$

module algorithm:

imports:

module stack

module list

module control

module num

module logic

__ greatest common divisor (using Euclid's algorithm)

gcd:

[] ap20 __ quote arguments [a b]

[[tuck %] .] __ step: [a b] -> [b (a % b)]

[head 0 !=] __ while: b != 0

iterate tail head __ return: a

__ acc x power -> if odd power, acc*x, otherwise acc

acc_odd_power: [[*] dip21 odd] ap20 ifdo

__ x power -> x*x power/2

reduce_power: [dup *] [1 >>b] para

__ acc x power -> acc' x^2 power/2

power_step: in2 [acc_odd_power] dip31 get2 reduce_power

__ raise to integer power using binary exponentiation

^:

[1 -swap2] ap20

[[power_step] .]

[head 0 !=]

iterate tail2 head

sum: 0 [ ] foldr

sumf: 0.0 [ f] foldr

avgf: dup sumf swap length ->f /f

__ decreasing list from initial element

__ ERROR: user_func.c:424: flat_call: Assertion `tn->pos' failed

__ iota: [1-] pushl [[dup 1-] .] [head 0 >] iterate

iota2: [[dup 1-] .] [head 0 >] iterate

__ iota3: [] pushl [[dup 1-] .] [head 0 >] iterate

__ x lo hi inrange -> bool

in_range: [over] dip23 <= [>=] dip21 and

module io:

imports:

module stack

module control

module logic

module list

read_std: "stream,in:std" open read [close] dip21

write_std: ["stream,out:std" open] dip12 write close

unread_std: ["stream,in:std" open] dip12 unread close

__ IO h buf

getline_loop:

[read] dip23 swap [] ap40 dup __ [IO h buf str] x2

__ no newline

[dup "" =s __ test for empty read

[drop] __ return buf

[ getline_loop] ifte ap43 swap3 drop] . swap __ continue

["\n" strsplit swap [ unread] dip42 dup] . __ newline

popr -swap2 swap vifte get3

getline: "" getline_loop

getline_std: "stream,in:std" open getline [close] dip21

__ IO h -> bool

is_eof:

read dup [unread] dip32 "" =s

__ Array addr [fn] -> Array

update_array: [tuck read_array [swap] dip22] dip23 $ write_array

__ Array a f -> Array

stream_modify_array1: [dup [read_array] dip22 swap] dip23 $ write_array

stream_modify_array:

[stream_modify_array1 dup True swap seq] pushl

[swap] dip22 map_with

__ [RA] -> [[Array -> Array R B]]

stream_read_array:

[[read_array quote __ [R]

[[]] pushl] __ [[R] []]

ap10] map

__ [WA] [W] -> [[Array -> Array R B]]

stream_write_array:

[[write_array dup [True swap seq] pushl __ [B]

[[] swap] pushl] __ [[] [B]]

ap20] zip

__ Array sRA sWA sW -> sR sB

stream_read_write_array_1:

[[write_array dup True swap seq [Right] pushl] ap20] zip

[[[read_array [Left] pushl] pushl] map] dip11

interleave

swap [$-] map_with

stream_read_write_array: stream_read_write_array_1 unzip_either

__ Array sRA -> sR sB {hide}

stream_read_write_array_ro:

[[read_array [Left] pushl] pushl] map

swap [$-] map_with

unzip_either

__ Array sWA sW -> sR sB {hide}

stream_read_write_array_wo:

[[write_array dup True swap seq [Right] pushl] ap20] zip

swap [$-] map_with

unzip_either