Skip to content
Permalink
master
Switch branches/tags

Name already in use

A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
Go to file
 
 
Cannot retrieve contributors at this time
__, 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