/* Array-programming in ProLog (APL.pl) The design goal is Prolog-first semantics with an APL-like surface: - one symbol, one arity - APL-style prefix verbs with fewer precedence surprises - backtracking preserved - CLP(Z)-first numeric core - plain Prolog values at the public boundary This is not a full APL. It is a compact expression language for writing Prolog relations and array transforms with a smaller surface syntax. Basic syntax: - numbers: `0`, `1`, `42` - negative numbers: `'3` means `-3` - vectors: `{1 2 3}` and vector items may be full expressions, e.g. `{1 + 2 3 + 4}` adjacent bare numbers, refs, and terms inside vectors split into separate items by default, so `{?x ?y}` is a two-item vector; use parentheses to force application when needed - grouping: `(Expr)` - env input: `?name` - env output/tap: `^name` Environment bindings use `Name=Value` or `Name-Value`. The special binding `module=Module` controls where named predicates are resolved; it defaults to `user`. Input and output refs: - `?name` reads a value from the environment - `^name Expr` evaluates `Expr`, unifies its plain Prolog value with `name` in the environment, and returns that same value unchanged - `?name` can also be used in verb position when the environment binds it to a builtin symbol, a predicate name atom, `ident(Name)`, or `host(Module, Name)` Examples: - `apl('?x + 2', [x=3], R)` gives `R = 5` - `apl('10 - 3 - 1', R)` gives `R = 6` - `apl('+/ ^x i 1 range 4', [x=X], R)` exports the current right side while still returning the reduction result - `apl('?f ?x', [f='$', x=[[1,2],[3,4]]], R)` calls the env-bound verb `$` Public result convention: - scalars are returned as scalars - rank-1 arrays are returned as lists - higher-rank arrays are returned as nested rectangular lists The internal array form is `arr(Shape, Data)`, but that is only exposed by `apl_raw/2,3`. Monadic verbs: - `~ Y` Arithmetic negation. Pervades over arrays. Example: `apl('~ {1 2 3}', R)` gives `[-1,-2,-3]`. - `$ Y` Shape. Returns the shape vector of `Y`. Example: `apl('$ ({2 3} # i 10)', R)` gives `[2,3]`. - `i Y` Iota. `Y` must be a non-negative integer scalar. Produces `[0,1,...,Y-1]`. Example: `apl('i 5', R)` gives `[0,1,2,3,4]`. - `t Y` Tally. Returns the leading-axis length of `Y`, or `1` for a scalar. Example: `apl('t {10 20 30}', R)` gives `3`. - `r Y` Reverse along the leading axis. Example: `apl('r {1 2 3}', R)` gives `[3,2,1]`. - `f Y` Flatten/ravel. Produces a rank-1 vector from any array. Example: `apl('f ({2 2} # i 5)', R)` gives `[0,1,2,3]`. - `z Y` Zero-test. Returns `1` where `Y` is zero and `0` otherwise. Pervades over arrays. Example: `apl('z ((i 10) % 3)', R)` gives `[1,0,0,1,0,0,1,0,0,1]`. Dyadic verbs: - `X + Y` CLP(Z) addition. Scalar-scalar and scalar-array/array-scalar/array-array pervasion are supported. - `X - Y` CLP(Z) subtraction with the same pervasion rules as `+`. - `X * Y` CLP(Z) multiplication with the same pervasion rules as `+`. - `X = Y` Prolog unification. Returns the side that had more free variables before the relation; ties return the right side. Example: `apl('?x = 3', [x=X], R)` gives `X = 3, R = 3`. - `X : Y` CLP(Z) equality using `#=/2`. Returns the side that had more free variables before the relation; ties return the right side. - `X < Y` CLP(Z) strict less-than using `# Y` CLP(Z) strict greater-than using `#>/2`. Returns the side that had more free variables before the relation; ties return the right side. - `X ! Y` Prolog disequality using `dif/2`. Returns the side that had more free variables before the relation; ties return the right side. Example: `apl('?x ! 3', [x=X], R), X = 5` gives `R = 5`. - `X e Y` Equality test. Returns `1` when `X` and `Y` are equal, otherwise `0`. For numeric values it is CLP(Z)-reified equality; for non-numeric values it currently requires both sides to be ground. Example: `apl('((i 10) % 3) e 0', R)` gives `[1,0,0,1,0,0,1,0,0,1]`. - `X d Y` Integer division relation. Example: `apl('7 d 2', R)` gives `3`. - `X % Y` Integer modulus relation. Example: `apl('7 % 3', R)` gives `1`. - `X , Y` Catenate along the leading axis. Scalars become elements, vectors append, and higher-rank arrays must match on trailing shape. - `Shape # Data` Reshape. The left side is the target shape, the right side is the source data. Extra data is truncated; short data is cycled. Examples: `apl('{2 3} # i 10', R)` gives `[[0,1,2],[3,4,5]]` `apl('5 # {1 2}', R)` gives `[1,2,1,2,1]` - `Data @ Index` Pick from the ravelled data vector. A scalar index returns one element; a vector of indices returns a vector of picked elements. Example: `apl('{10 20 30} @ {2 0}', R)` gives `[30,10]`. - `Mask m Data` Mask/filter by a prefix-shaped mask. `0` drops, any non-zero value keeps. The mask shape must match a leading prefix of the right shape. Example: `apl('{1 0 1} m {10 20 30}', R)` gives `[10,30]`. Example: `apl('{1 0 1} m ({3 2} # i 10)', R)` keeps rows 0 and 2. - `A & B` Goal conjunction. Runs `A`, then `B`, and returns the value from `B`. This is for composing logical goals, not scalar arithmetic. - `A | B` Goal disjunction. Branches between `A` and `B`. Operators: - `F/ Y` Reduce over the leading axis using dyad `F`. Example: `apl('+/ ({3 3} # i 10)', R)` gives `[9,12,15]`. - `F\ Y` Scan over the leading axis using dyad `F`. Example: `apl('+\\ ({3 3} # i 10)', R)` gives `[[0,1,2],[3,5,7],[9,12,15]]`. Parsing and precedence: - `|` binds loosest, then `&` - `m` binds looser than comparisons such as `e` and `:` - `+` and `-` bind looser than `*`, `d`, and `%` - prefix verbs like `i`, `$`, `z`, `F/`, and `F\` still read rightward over the next ordinary expression - ordinary dyad tiers associate left-to-right, so `10 - 3 - 1` parses as `(10 - 3) - 1` - parentheses can always be used to force grouping Named predicates: Bare identifiers are resolved as Prolog predicates in the selected module: - bare `gen` calls `gen/1` - `inc X` calls `inc(X, Result)` - `A between B` calls `between(A, B, Result)` These relations preserve normal Prolog backtracking. Most named predicates are scalar host verbs and therefore pervade over arrays. The bundled structural helpers `transpose/2`, `where/2`, and `col/3` are array-level helpers instead: they consume whole arrays as plain Prolog terms. Bundled named predicates: - `range/3` Portable integer enumeration, similar to `between/3` - `oneof/2` Enumerate the members of a list - `le/3` CLP(Z) `#=<` relation returning the more informative side - `ge/3` CLP(Z) `#>=` relation returning the more informative side - `neq/3` Disequality relation returning the more informative side - `col/3` Select one column-like slice along axis 1, e.g. `2 col Matrix` Example: `apl('1 col ({3 2} # i 10)', R)` gives `[1,3,5]` - `transpose/2` Transpose the first two axes of an array; scalars and vectors are unchanged Example: `apl('transpose ({2 3} # i 10)', R)` gives `[[0,3],[1,4],[2,5]]` - `where/2` Return the ravel indices of truthy cells in a mask Example: `apl('where ((1 + i 10) % 3 e 0)', R)` gives `[2,5,8]` Errors: Shape mismatches, bad indices, invalid expressions, non-rectangular lists, and other structural mistakes throw explicit `apl_error(...)` exceptions rather than failing silently. ^ ^ =(o.o)= m m ~byakuren */ :- module(apl, [ apl/2, apl/3, apl_goal/1, apl_goal/2, apl_ast/2, apl_eval/2, apl_eval/3, apl_raw/2, apl_raw/3, range/3, oneof/2, le/3, ge/3, neq/3, col/3, transpose/2, where/2 ]). :- use_module(library(lists), [length/2, member/2, reverse/2]). :- use_module(library(clpz)). :- use_module(library(dif)). % ============================================================================ % Public API % ============================================================================ %% apl(+Input, -Result) is nondet. % % Evaluate an APL expression with an empty environment. apl(Input, Result) :- apl(Input, [], Result). %% apl(+Input, +Env, -Result) is nondet. % % Evaluate an APL expression against Env and return plain Prolog values. apl(Input, Env, Result) :- input_ast(Input, AST), eval_term(AST, Env, Result). %% apl_goal(+Input) is nondet. % % Evaluate an APL expression for its logical effects only. apl_goal(Input) :- apl_goal(Input, []). %% apl_goal(+Input, +Env) is nondet. % % Evaluate an APL expression for its logical effects using Env. apl_goal(Input, Env) :- input_ast(Input, AST), eval(AST, Env, _). %% apl_ast(+Input, -AST) is det. % % Parse Input into the internal AST representation. apl_ast(Input, AST) :- input_ast(Input, AST). %% apl_eval(+AST, -Result) is nondet. % % Evaluate a parsed AST with an empty environment. apl_eval(AST, Result) :- apl_eval(AST, [], Result). %% apl_eval(+AST, +Env, -Result) is nondet. % % Evaluate a parsed AST against Env and return plain Prolog values. apl_eval(AST, Env, Result) :- eval_term(AST, Env, Result). %% apl_raw(+Input, -Raw) is nondet. % % Evaluate Input and return the internal `arr(Shape, Data)` representation. apl_raw(Input, Result) :- apl_raw(Input, [], Result). %% apl_raw(+Input, +Env, -Raw) is nondet. % % Evaluate Input against Env and return the internal `arr(Shape, Data)` form. apl_raw(Input, Env, Result) :- input_ast(Input, AST), eval(AST, Env, Result). input_ast(Input, AST) :- input_chars(Input, Chars), tokenize(Chars, Tokens), parse(Tokens, AST). eval_term(AST, Env, Result) :- eval(AST, Env, Raw), array_term(Raw, Result). % ============================================================================ % Tokenizer DCG % ============================================================================ tokenize(Chars, Tokens) :- phrase(tokens(Tokens), Chars). tokens([Token|Tokens]) --> blanks, token(Token), !, tokens(Tokens). tokens([]) --> blanks, eos. token(lparen) --> ['(']. token(rparen) --> [')']. token(lbrace) --> ['{']. token(rbrace) --> ['}']. token(ref(Name)) --> ['?'], !, ref_name(Name). token(out(Name)) --> ['^'], !, out_name(Name). token(num(N)) --> ['\''], !, integer_chars(Ds), { number_chars(Abs, Ds), N is -Abs }. token(num(N)) --> integer_chars(Ds), { number_chars(N, Ds) }. token(Token) --> ident_name(Name), { classify_ident(Name, Token) }. token(C) --> [C], { is_sym(C) }. token(_) --> [C], { throw(error(syntax_error(unexpected_char(C)), _)) }. ref_name(Name) --> ident_name(Name), !. ref_name(_) --> { throw(error(syntax_error(bad_ref), _)) }. out_name(Name) --> ident_name(Name), !. out_name(_) --> { throw_apl_error(bad_export_ref) }. integer_chars([D|Ds]) --> digit_char_dcg(D), digit_chars(Ds). digit_chars([D|Ds]) --> digit_char_dcg(D), !, digit_chars(Ds). digit_chars([]) --> []. ident_name(Name) --> ident_start_char(C), ident_rest(Cs), { atom_chars(Name, [C|Cs]) }. ident_rest([C|Cs]) --> ident_continue_char(C), !, ident_rest(Cs). ident_rest([]) --> []. blanks --> blank_char, !, blanks. blanks --> []. blank_char --> [C], { is_space(C) }. digit_char_dcg(C) --> [C], { is_digit(C) }. ident_start_char(C) --> [C], { is_ident_start(C) }. ident_continue_char(C) --> [C], { is_ident_continue(C) }. eos([], []). classify_ident(Name, Token) :- atom_chars(Name, [C]), is_sym(C), !, Token = C. classify_ident(Name, ident(Name)). is_space(' '). is_space('\t'). is_space('\n'). is_space('\r'). is_digit(C) :- C @>= '0', C @=< '9'. alpha_char(C) :- lower_alpha_char(C). alpha_char(C) :- upper_alpha_char(C). lower_alpha_char(C) :- C @>= a, C @=< z. upper_alpha_char(C) :- C @>= 'A', C @=< 'Z'. is_ident_start('_'). is_ident_start(C) :- alpha_char(C). is_ident_continue(C) :- is_ident_start(C). is_ident_continue(C) :- is_digit(C). % ============================================================================ % Symbol classification % ============================================================================ monadic_char('~'). monadic_char('$'). monadic_char(i). monadic_char(t). monadic_char(r). monadic_char(f). monadic_char(z). dyadic_char('+'). dyadic_char('-'). dyadic_char('*'). dyadic_char('='). dyadic_char(':'). dyadic_char('<'). dyadic_char('>'). dyadic_char('!'). dyadic_char(e). dyadic_char(d). dyadic_char('%'). dyadic_char('&'). dyadic_char('|'). dyadic_char(','). dyadic_char('#'). dyadic_char('@'). dyadic_char(m). operator_char('/'). operator_char('\\'). is_sym(C) :- monadic_char(C). is_sym(C) :- dyadic_char(C). is_sym(C) :- operator_char(C). % ============================================================================ % Parser DCG % ============================================================================ % AST nodes: % num/1, ref/1, term/1, vec/1, export/2, monad/2, dyad/3, reduce/2, scan/2 % % Parsing uses low-precedence goal combiners and tighter ordinary verb tiers. % Prefix verbs/operators still read rightward over the next ordinary % expression, but dyadic tiers reduce the amount of parenthesizing needed for % arithmetic and masking pipelines. parse(Tokens, AST) :- ( phrase(expr(AST), Tokens) -> true ; throw_apl_error(invalid_expression(Tokens)) ). expr(AST) --> disj(AST). disj(AST) --> conj(Left), disj_rest(Left, AST). disj_rest(Left, dyad('|', Left, Right)) --> ['|'], !, disj(Right). disj_rest(AST, AST) --> []. conj(AST) --> ordinary_expr(Left), conj_rest(Left, AST). conj_rest(Left, dyad('&', Left, Right)) --> ['&'], !, conj(Right). conj_rest(AST, AST) --> []. ordinary_expr(AST) --> mask_expr(AST). mask_expr(AST) --> compare_expr(Left), mask_expr_rest(Left, AST). mask_expr_rest(Left, AST) --> [m], !, compare_expr(Right), { Next = dyad(m, Left, Right) }, mask_expr_rest(Next, AST). mask_expr_rest(AST, AST) --> []. compare_expr(AST) --> application_expr(Left), compare_expr_rest(Left, AST). compare_expr_rest(Left, AST) --> [Fun], { compare_token(Fun) }, !, application_expr(Right), { Next = dyad(Fun, Left, Right) }, compare_expr_rest(Next, AST). compare_expr_rest(AST, AST) --> []. application_expr(AST) --> additive_expr(Left), application_expr_rest(Left, AST). application_expr_rest(Left, AST) --> [Fun], { application_token(Fun) }, !, additive_expr(Right), { Next = dyad(Fun, Left, Right) }, application_expr_rest(Next, AST). application_expr_rest(AST, AST) --> []. additive_expr(AST) --> multiplicative_expr(Left), additive_expr_rest(Left, AST). additive_expr_rest(Left, AST) --> [Fun], { additive_token(Fun) }, !, multiplicative_expr(Right), { Next = dyad(Fun, Left, Right) }, additive_expr_rest(Next, AST). additive_expr_rest(AST, AST) --> []. multiplicative_expr(AST) --> prefix_expr(Left), multiplicative_expr_rest(Left, AST). multiplicative_expr_rest(Left, AST) --> [Fun], { multiplicative_token(Fun) }, !, prefix_expr(Right), { Next = dyad(Fun, Left, Right) }, multiplicative_expr_rest(Next, AST). multiplicative_expr_rest(AST, AST) --> []. prefix_expr(export(Name, Omega)) --> [out(Name)], !, ordinary_expr(Omega). prefix_expr(OpAST) --> [Fun, Op], { fun_token(Fun), operator_char(Op) }, !, ordinary_expr(Omega), { make_op(Op, Fun, Omega, OpAST) }. prefix_expr(monad(Fun, Omega)) --> [Fun], { monad_token(Fun) }, ordinary_expr(Omega), !. prefix_expr(AST) --> operand(AST). operand(num(N)) --> [num(N)]. operand(ref(Name)) --> [ref(Name)]. operand(term(Name)) --> [ident(Name)]. operand(Expr) --> [lparen], expr(Expr), [rparen]. operand(vec(Items)) --> [lbrace], vec_items(Items), [rbrace]. vec_items([Item|Items]) --> vec_item(Item), vec_items(Items). vec_items([]) --> []. % Inside vectors, adjacent bare values are preferred as separate items. This % keeps `{?x ?y}` and `{foo bar}` data-oriented by default while still letting % grouped or symbol-led expressions force application when needed. vec_item(Item) --> vec_bare_item(Item), vec_bare_boundary, !. vec_item(Item) --> expr(Item). vec_bare_item(num(N)) --> [num(N)]. vec_bare_item(ref(Name)) --> [ref(Name)]. vec_bare_item(term(Name)) --> [ident(Name)]. vec_bare_boundary([rbrace|Rest], [rbrace|Rest]). vec_bare_boundary([Token|Rest], [Token|Rest]) :- vec_bare_start_token(Token). vec_bare_start_token(num(_)). vec_bare_start_token(ref(_)). vec_bare_start_token(ident(_)). fun_token(Fun) :- dyad_token(Fun). monad_token(Fun) :- monadic_char(Fun). monad_token(ident(_)). monad_token(ref(_)). dyad_token(Fun) :- dyadic_char(Fun). dyad_token(ident(_)). dyad_token(ref(_)). compare_token('='). compare_token(':'). compare_token('<'). compare_token('>'). compare_token('!'). compare_token(e). application_char(','). application_char('#'). application_char('@'). application_token(Fun) :- application_char(Fun). application_token(ident(_)). application_token(ref(_)). additive_token('+'). additive_token('-'). multiplicative_token('*'). multiplicative_token(d). multiplicative_token('%'). make_op('/', Fun, Omega, reduce(Fun, Omega)). make_op('\\', Fun, Omega, scan(Fun, Omega)). % ============================================================================ % Evaluator % ============================================================================ eval(num(N), _, arr([], [N])). eval(ref(Name), Env, Arr) :- env_lookup(Name, Env, Value), term_array(Value, Arr). eval(term(Name), Env, Arr) :- apl_call_env(Env, Name, [Value]), term_array(Value, Arr). eval(export(Name, Expr), Env, Arr) :- eval(Expr, Env, Arr), array_term(Arr, Term), env_store(Name, Env, Term). eval(vec(Items), Env, Arr) :- eval_vec(Items, Env, Arr). eval(monad(FunExpr, OmegaExpr), Env, Result) :- resolve_fun(FunExpr, Env, Fun), eval(OmegaExpr, Env, Omega), eval_monad(Fun, Omega, Result). eval(dyad(FunExpr, AlphaExpr, OmegaExpr), Env, Result) :- resolve_fun(FunExpr, Env, Fun), eval_dyad_expr(Fun, AlphaExpr, OmegaExpr, Env, Result). eval(reduce(FunExpr, OmegaExpr), Env, Result) :- resolve_fun(FunExpr, Env, Fun), require_axis_fun(reduce, Fun), eval(OmegaExpr, Env, Omega), reduce_first_axis(Fun, Omega, Result). eval(scan(FunExpr, OmegaExpr), Env, Result) :- resolve_fun(FunExpr, Env, Fun), require_axis_fun(scan, Fun), eval(OmegaExpr, Env, Omega), scan_first_axis(Fun, Omega, Result). % The first item fixes the common element shape for the whole vector. eval_vec([], _, arr([0], [])). eval_vec([Item|Items], Env, arr([N|Shape], Data)) :- length([Item|Items], N), eval(Item, Env, arr(Shape, ItemData)), list_prefix(ItemData, Data, Tail), eval_vec_items(Items, Env, Shape, Tail, []). eval_vec_items([], _, _, Tail, Tail). eval_vec_items([Item|Items], Env, Shape, Data, Tail) :- eval(Item, Env, arr(Shape, ItemData)), list_prefix(ItemData, Data, Next), eval_vec_items(Items, Env, Shape, Next, Tail). eval_dyad_expr('&', AlphaExpr, OmegaExpr, Env, Result) :- eval(AlphaExpr, Env, _), eval(OmegaExpr, Env, Result). eval_dyad_expr('|', AlphaExpr, _, Env, Result) :- eval(AlphaExpr, Env, Result). eval_dyad_expr('|', _, OmegaExpr, Env, Result) :- eval(OmegaExpr, Env, Result). eval_dyad_expr(Fun, AlphaExpr, OmegaExpr, Env, Result) :- eval(AlphaExpr, Env, Alpha), eval(OmegaExpr, Env, Omega), eval_dyad(Fun, Alpha, Omega, Result). eval_monad(host(Module, Name), Omega, Result) :- array_level_monad(Name), !, apply_array_monad(Module, Name, Omega, Result). eval_monad(Fun, Omega, Result) :- pervasive_monad(Fun), !, pv_m(Fun, Omega, Result). eval_monad(host(Module, Name), Omega, Result) :- pv_m(host(Module, Name), Omega, Result). eval_monad('$', arr(Shape, _), Result) :- term_array(Shape, Result). eval_monad(t, Arr, Result) :- tally_of(Arr, N), Result = arr([], [N]). eval_monad(i, arr([], [N]), Result) :- require_nonneg_integer(iota, N), iota_array(N, Result). eval_monad(r, arr([], [V]), arr([], [V])) :- !. eval_monad(r, arr([N|Dims], Data), arr([N|Dims], RevData)) :- major_cells(Dims, Data, Cells), reverse(Cells, RevCells), flatten_cells(RevCells, RevData). eval_monad(f, arr(_, Data), arr([N], Data)) :- length(Data, N). eval_dyad(host(Module, Name), Alpha, Omega, Result) :- array_level_dyad(Name), !, apply_array_dyad(Module, Name, Alpha, Omega, Result). eval_dyad(Fun, Alpha, Omega, Result) :- pervasive_dyad(Fun), !, pv_d(Fun, Alpha, Omega, Result). eval_dyad(host(Module, Name), Alpha, Omega, Result) :- pv_d(host(Module, Name), Alpha, Omega, Result). eval_dyad(Fun, _, _, _) :- goal_combiner(Fun), throw_apl_error(not_scalar_dyad(Fun)). eval_dyad(',', Alpha, Omega, Result) :- catenate_arrays(Alpha, Omega, Result). eval_dyad('#', ShapeArr, DataArr, Result) :- reshape_array(ShapeArr, DataArr, Result). eval_dyad('@', DataArr, IndexArr, Result) :- pick_array(DataArr, IndexArr, Result). eval_dyad(m, MaskArr, RightArr, Result) :- mask_array(MaskArr, RightArr, Result). % ============================================================================ % Pervasion % ============================================================================ pv_m(Fun, arr([], [V]), arr([], [R])) :- !, apply_m(Fun, V, R). pv_m(Fun, arr(Shape, Data), arr(Shape, Rs)) :- map_apply_m(Fun, Data, Rs). map_apply_m(_, [], []). map_apply_m(Fun, [D|Ds], [R|Rs]) :- apply_m(Fun, D, R), map_apply_m(Fun, Ds, Rs). pv_d(Fun, arr([], [A]), arr([], [B]), arr([], [R])) :- !, apply_d(Fun, A, B, R). pv_d(Fun, arr([], [A]), arr(Shape, Data), arr(Shape, Rs)) :- !, map_d_left(Fun, A, Data, Rs). pv_d(Fun, arr(Shape, Data), arr([], [B]), arr(Shape, Rs)) :- !, map_d_right(Fun, Data, B, Rs). pv_d(Fun, arr(Shape, DataA), arr(Shape, DataB), arr(Shape, Rs)) :- zip_d(Fun, DataA, DataB, Rs). pv_d(Fun, arr(ShapeA, _), arr(ShapeB, _), _) :- throw_apl_error(shape_mismatch(pervasion(Fun), ShapeA, ShapeB)). pervasive_monad('~'). pervasive_monad(z). pervasive_dyad('+'). pervasive_dyad('-'). pervasive_dyad('*'). pervasive_dyad('='). pervasive_dyad(':'). pervasive_dyad('<'). pervasive_dyad('>'). pervasive_dyad('!'). pervasive_dyad(e). pervasive_dyad(d). pervasive_dyad('%'). goal_combiner('&'). goal_combiner('|'). array_level_monad(transpose). array_level_monad(where). array_level_dyad(col). apply_array_monad(Module, Name, Omega, Result) :- array_term(Omega, OmegaTerm), apl_call(Module, Name, [OmegaTerm, ResultTerm]), term_array(ResultTerm, Result). apply_array_dyad(Module, Name, Alpha, Omega, Result) :- array_term(Alpha, AlphaTerm), array_term(Omega, OmegaTerm), apl_call(Module, Name, [AlphaTerm, OmegaTerm, ResultTerm]), term_array(ResultTerm, Result). map_d_left(_, _, [], []). map_d_left(Fun, A, [B|Bs], [R|Rs]) :- apply_d(Fun, A, B, R), map_d_left(Fun, A, Bs, Rs). map_d_right(_, [], _, []). map_d_right(Fun, [A|As], B, [R|Rs]) :- apply_d(Fun, A, B, R), map_d_right(Fun, As, B, Rs). zip_d(_, [], [], []). zip_d(Fun, [A|As], [B|Bs], [R|Rs]) :- apply_d(Fun, A, B, R), zip_d(Fun, As, Bs, Rs). apply_m('~', V, R) :- R #= -V. apply_m(z, V, R) :- B #<==> V #= 0, R #= B. apply_m(host(Module, Name), V, R) :- apl_call(Module, Name, [V, R]). apply_d('+', X, Y, R) :- R #= X + Y. apply_d('-', X, Y, R) :- R #= X - Y. apply_d('*', X, Y, R) :- R #= X * Y. apply_d('=', X, Y, R) :- relational_apply(unify, X, Y, R). apply_d(':', X, Y, R) :- relational_apply(clpz_eq, X, Y, R). apply_d('<', X, Y, R) :- relational_apply(clpz_lt, X, Y, R). apply_d('>', X, Y, R) :- relational_apply(clpz_gt, X, Y, R). apply_d('!', X, Y, R) :- relational_apply(different, X, Y, R). apply_d(e, X, Y, R) :- equality_test(X, Y, R). apply_d(d, X, Y, R) :- 'div'(X, Y, R). apply_d('%', X, Y, R) :- 'mod'(X, Y, R). apply_d(host(Module, Name), X, Y, R) :- apl_call(Module, Name, [X, Y, R]). % Relational dyads return the side that looked most like an output before the % relation was applied, approximated by the side with more free variables. relational_apply(Relation, Alpha, Omega, Result) :- relational_choice(Alpha, Omega, Choice), relation_holds(Relation, Alpha, Omega), relational_result(Choice, Alpha, Omega, Result). relation_holds(unify, X, Y) :- X = Y. relation_holds(clpz_eq, X, Y) :- X #= Y. relation_holds(clpz_lt, X, Y) :- X #< Y. relation_holds(clpz_gt, X, Y) :- X #> Y. relation_holds(clpz_le, X, Y) :- X #=< Y. relation_holds(clpz_ge, X, Y) :- X #>= Y. relation_holds(different, X, Y) :- dif(X, Y). relational_choice(Alpha, Omega, Choice) :- free_variable_count(Alpha, AlphaCount), free_variable_count(Omega, OmegaCount), ( AlphaCount > OmegaCount -> Choice = alpha ; Choice = omega ). free_variable_count(Term, Count) :- term_variables(Term, Vars), length(Vars, Count). relational_result(alpha, Alpha, _, Alpha). relational_result(omega, _, Omega, Omega). equality_test(X, Y, R) :- ( clpz_comparable(X), clpz_comparable(Y) -> B #<==> X #= Y, R #= B ; ground(X), ground(Y) -> ( X == Y -> R = 1 ; R = 0 ) ; throw_apl_error(non_ground_equality_test(X, Y)) ). clpz_comparable(X) :- var(X), !. clpz_comparable(X) :- integer(X). % ============================================================================ % Structural verbs % ============================================================================ catenate_arrays(arr([], [A]), arr([], [B]), arr([2], [A, B])) :- !. catenate_arrays(arr([], [A]), arr([N], Data), arr([N1], [A|Data])) :- !, N1 is N + 1. catenate_arrays(arr([N], Data), arr([], [B]), arr([N1], Result)) :- !, N1 is N + 1, list_prefix(Data, Result, [B]). catenate_arrays(arr([NA|Dims], DataA), arr([NB|Dims], DataB), arr([N|Dims], Data)) :- N is NA + NB, list_prefix(DataA, Data, DataB). catenate_arrays(arr(ShapeA, _), arr(ShapeB, _), _) :- throw_apl_error(shape_mismatch(catenate, ShapeA, ShapeB)). reshape_array(arr([], [N]), arr(_, Data), Result) :- !, require_nonneg_integer(reshape, N), make_array([N], Data, Result). reshape_array(arr([_], Shape), arr(_, Data), Result) :- require_integer_list(reshape, Shape), make_array(Shape, Data, Result). pick_array(arr(_, Data), arr([], [Idx]), arr([], [Elem])) :- !, require_nonneg_integer(pick, Idx), nth0_checked(pick, Idx, Data, Elem). pick_array(arr(_, Data), arr([N], Indices), arr([N], Elems)) :- require_integer_list(pick, Indices), pick_all(Data, Indices, Elems). pick_all(_, [], []). pick_all(Data, [Idx|Idxs], [Elem|Elems]) :- nth0_checked(pick, Idx, Data, Elem), pick_all(Data, Idxs, Elems). mask_array(arr([], [Mask]), Right, Result) :- !, require_ground_mask(Mask), ( truthy_mask(Mask) -> Result = Right ; empty_mask_result(Right, Result) ). mask_array(arr(MaskShape, Masks), arr(RightShape, RightData), arr(ResultShape, KeptData)) :- require_ground_list(mask, Masks), prefix_shape(MaskShape, RightShape, CellShape), product_list(CellShape, CellSize), mask_cells(Masks, RightData, CellSize, KeptCount, KeptData), mask_result_shape(CellShape, KeptCount, ResultShape). require_ground_mask(Mask) :- ground(Mask), !. require_ground_mask(_) :- throw(error(instantiation_error, mask)). require_ground_list(_, []). require_ground_list(Context, [X|Xs]) :- ( ground(X) -> true ; throw(error(instantiation_error, Context)) ), require_ground_list(Context, Xs). empty_mask_result(arr([], _), arr([0], [])) :- !. empty_mask_result(arr([_|CellShape], _), arr([0|CellShape], [])). prefix_shape([], Shape, Shape). prefix_shape([Dim|Dims], [Dim|RightDims], CellShape) :- prefix_shape(Dims, RightDims, CellShape). prefix_shape(MaskShape, RightShape, _) :- throw_apl_error(shape_mismatch(mask, MaskShape, RightShape)). mask_cells(Masks, Data0, CellSize, Count, KeptData) :- mask_cells(Masks, Data0, CellSize, Count, KeptData, []). mask_cells([], [], _, 0, Tail, Tail). mask_cells([Mask|Masks], Data0, CellSize, Count, KeptData, Tail) :- split_n(CellSize, Data0, Cell, Data1), mask_cells(Masks, Data1, CellSize, Count0, RestData, Tail), ( truthy_mask(Mask) -> Count is Count0 + 1, list_prefix(Cell, KeptData, RestData) ; Count = Count0, KeptData = RestData ). mask_result_shape([], KeptCount, [KeptCount]). mask_result_shape(CellShape, KeptCount, [KeptCount|CellShape]). truthy_mask(Mask) :- Mask =\= 0. % ============================================================================ % Reduce / scan over the leading axis % ============================================================================ reduce_first_axis(_, arr([], [V]), arr([], [V])) :- !. reduce_first_axis(Fun, arr([0|Dims], _), _) :- throw_apl_error(empty_axis(reduce(Fun), [0|Dims])). reduce_first_axis(Fun, arr([N|Dims], Data), Result) :- N > 0, major_cells(Dims, Data, [Cell|Cells]), reduce_cells(Fun, Cell, Cells, Result). reduce_cells(_, Acc, [], Acc). reduce_cells(Fun, Acc, [Cell|Cells], Result) :- eval_dyad(Fun, Acc, Cell, Next), reduce_cells(Fun, Next, Cells, Result). scan_first_axis(_, arr([], [V]), arr([], [V])) :- !. scan_first_axis(Fun, arr([0|Dims], _), _) :- throw_apl_error(empty_axis(scan(Fun), [0|Dims])). scan_first_axis(Fun, arr([N|Dims], Data), arr([N|Dims], Flat)) :- N > 0, major_cells(Dims, Data, [Cell|Cells]), scan_cells(Fun, Cell, Cells, Scanned), flatten_cells([Cell|Scanned], Flat). scan_cells(_, _, [], []). scan_cells(Fun, Acc, [Cell|Cells], [Next|Scanned]) :- eval_dyad(Fun, Acc, Cell, Next), scan_cells(Fun, Next, Cells, Scanned). major_cells(Dims, Data, Cells) :- product_list(Dims, CellSize), split_cells(CellSize, Dims, Data, Cells). split_cells(_, _, [], []). split_cells(CellSize, Dims, Data0, [arr(Dims, CellData)|Cells]) :- split_n(CellSize, Data0, CellData, Data1), split_cells(CellSize, Dims, Data1, Cells). flatten_cells(Cells, Flat) :- flatten_cells(Cells, Flat, []). flatten_cells([], Tail, Tail). flatten_cells([arr(_, CellData)|Cells], Flat, Tail) :- list_prefix(CellData, Flat, Next), flatten_cells(Cells, Next, Tail). % ============================================================================ % Array model and conversion % ============================================================================ tally_of(arr([], _), 1). tally_of(arr([N|_], _), N). product_list([], 1). product_list([H|T], P) :- product_list(T, P0), P is H * P0. make_array(Shape, Data, arr(Shape, Cycled)) :- product_list(Shape, Need), require_reshape_data(Shape, Need, Data), cycle_data(Data, Need, Cycled). cycle_data(_, 0, []) :- !. cycle_data(Data, Need, Result) :- Need > 0, length(Data, Len), Len > 0, ( Len >= Need -> take_n(Need, Data, Result) ; list_prefix(Data, Result, Rest), Need2 is Need - Len, cycle_data(Data, Need2, Rest) ). take_n(0, _, []) :- !. take_n(N, [H|T], [H|R]) :- N > 0, N1 is N - 1, take_n(N1, T, R). split_n(0, Rest, [], Rest) :- !. split_n(N, [H|T], [H|Chunk], Rest) :- N > 0, N1 is N - 1, split_n(N1, T, Chunk, Rest). nth0_exact(0, [H|_], H) :- !. nth0_exact(N, [_|T], Elem) :- N > 0, N1 is N - 1, nth0_exact(N1, T, Elem). nth0_checked(Context, Index, List, Elem) :- length(List, Len), ( Index < Len -> nth0_exact(Index, List, Elem) ; throw_apl_error(index_out_of_range(Context, Index, Len)) ). iota_array(0, arr([0], [])) :- !. iota_array(N, arr([N], Data)) :- N > 0, iota_list(0, N, Data). iota_list(I, N, []) :- I >= N, !. iota_list(I, N, [I|Rest]) :- I < N, I1 is I + 1, iota_list(I1, N, Rest). % Lists are treated as rectangular arrays; the first element fixes cell shape. term_array(Term, arr(Shape, Data)) :- nonvar(Term), Term = arr(Shape, Data), !. term_array(Term, arr([N|ItemShape], Data)) :- nonvar(Term), proper_list(Term), !, length(Term, N), list_items_array(Term, ItemShape, Data). term_array(Term, arr([], [Term])). list_items_array([], [], []). list_items_array([Item|Items], Shape, Data) :- term_array(Item, arr(Shape, ItemData)), list_prefix(ItemData, Data, Tail), list_items_same_shape(Items, Shape, Tail, []). list_items_same_shape([], _, Tail, Tail). list_items_same_shape([Item|Items], Shape, Data, Tail) :- term_array(Item, arr(ItemShape, ItemData)), ensure_same_shape(list, Shape, ItemShape), list_prefix(ItemData, Data, Next), list_items_same_shape(Items, Shape, Next, Tail). proper_list([]). proper_list([_|Xs]) :- proper_list(Xs). array_term(arr([], [V]), V) :- !. array_term(arr([_], Data), Data) :- !. array_term(arr(Shape, Data), Term) :- shape_term(Shape, Data, Term). shape_term([], [V], V) :- !. shape_term([_], Data, Data) :- !. shape_term([N|Dims], Data, Rows) :- product_list(Dims, BlockSize), shape_rows(N, Dims, BlockSize, Data, Rows). shape_rows(0, _, _, _, []) :- !. shape_rows(N, Dims, BlockSize, Data0, [Row|Rows]) :- N > 0, split_n(BlockSize, Data0, Chunk, Data1), shape_term(Dims, Chunk, Row), N1 is N - 1, shape_rows(N1, Dims, BlockSize, Data1, Rows). % ============================================================================ % Environment and host predicate dispatch % ============================================================================ env_binding(Name, Value, Name=Value). env_binding(Name, Value, Name-Value). env_lookup(Name, [Binding|_], Value) :- env_binding(Name, Value, Binding), !. env_lookup(Name, [_|Rest], Value) :- env_lookup(Name, Rest, Value). env_lookup(Name, [], _) :- throw(error(existence_error(apl_ref, Name), _)). env_store(Name, [Binding|_], Value) :- env_binding(Name, Stored, Binding), !, ( Stored = Value -> true ; throw_apl_error(export_conflict(Name, Stored, Value)) ). env_store(Name, [_|Rest], Value) :- env_store(Name, Rest, Value). env_store(Name, [], _) :- throw(error(existence_error(apl_export, Name), _)). env_module([Binding|_], Module) :- env_binding(module, Module, Binding), !. env_module([_|Rest], Module) :- env_module(Rest, Module). env_module([], user). resolve_fun(ref(Name), Env, Fun) :- env_lookup(Name, Env, Value), normalize_fun_value(Value, Env, Fun). resolve_fun(ident(Name), Env, host(Module, Name)) :- env_module(Env, Module), !. resolve_fun(Fun, _, Fun). normalize_fun_value(host(Module, Name), _, host(Module, Name)) :- atom(Module), atom(Name), !. normalize_fun_value(ident(Name), Env, host(Module, Name)) :- env_module(Env, Module), !. normalize_fun_value(Fun, _, Fun) :- atom(Fun), atom_chars(Fun, [C]), ( monadic_char(C) ; dyadic_char(C) ), !. normalize_fun_value(Name, Env, host(Module, Name)) :- atom(Name), env_module(Env, Module), !. normalize_fun_value(Value, _, _) :- throw_apl_error(bad_verb_reference(Value)). apl_call_env(Env, Name, Args) :- env_module(Env, Module), apl_call(Module, Name, Args). apl_call(Module, Name, Args) :- length(Args, Arity), host_goal_module(Module, Name, Arity, GoalModule), Goal =.. [Name|Args], call(GoalModule:Goal). host_goal_module(apl, _, _, apl) :- !. host_goal_module(Module, Name, Arity, apl) :- bundled_predicate(Name, Arity), \+ predicate_in_context(Module, Name, Arity), !. host_goal_module(Module, _, _, Module). predicate_in_context(Module, Name, Arity) :- Pred = Name/Arity, Module:current_predicate(Pred). bundled_predicate(range, 3). bundled_predicate(oneof, 2). bundled_predicate(le, 3). bundled_predicate(ge, 3). bundled_predicate(neq, 3). bundled_predicate(col, 3). bundled_predicate(transpose, 2). bundled_predicate(where, 2). bundled_predicate(div, 3). bundled_predicate(mod, 3). require_axis_fun(Context, Fun) :- ( goal_combiner(Fun) -> throw_apl_error(invalid_operator_fun(Context, Fun)) ; true ). % ============================================================================ % Bundled named predicates % ============================================================================ %% range(+Lower, +Upper, -Value) is nondet. % % Portable integer enumeration, similar to between/3. range(Lower, Upper, Value) :- require_integer(range, Lower), require_integer(range, Upper), range_(Lower, Upper, Value). range_(Lower, Upper, Lower) :- Lower =< Upper. range_(Lower, Upper, Value) :- Lower < Upper, Next is Lower + 1, range_(Next, Upper, Value). %% oneof(+Choices, -Choice) is nondet. % % Enumerate the members of Choices. oneof(Choices, Choice) :- member(Choice, Choices). %% le(+X, +Y, -Result) is nondet. % % Constrain X #=< Y and return the side with more free variables before the % relation; ties return the right side. le(X, Y, Result) :- relational_apply(clpz_le, X, Y, Result). %% ge(+X, +Y, -Result) is nondet. % % Constrain X #>= Y and return the side with more free variables before the % relation; ties return the right side. ge(X, Y, Result) :- relational_apply(clpz_ge, X, Y, Result). %% neq(+X, +Y, -Result) is nondet. % % Constrain X and Y to be different and return the side with more free % variables before the relation; ties return the right side. neq(X, Y, Result) :- relational_apply(different, X, Y, Result). %% col(+Index, +Array, -Column) is det. % % Select the Index-th cell along axis 1 from each leading-axis cell of Array. % For a matrix this is the usual column operation. col(Index, Array, Column) :- require_nonneg_integer(col, Index), term_array(Array, Arr), col_array(Index, Arr, ColArr), array_term(ColArr, Column). %% transpose(+Array, -Transpose) is det. % % Transpose the first two axes of Array. Scalars and vectors are unchanged. transpose(Array, Transpose) :- term_array(Array, Arr), transpose_array(Arr, Transposed), array_term(Transposed, Transpose). %% where(+Mask, -Indices) is det. % % Return the ravel indices of the truthy cells in Mask. where(Mask, Indices) :- term_array(Mask, arr(_, Data)), require_ground_list(where, Data), truthy_indices(Data, 0, Indices). %% 'div'(+X, +Y, -Result) is nondet. % % Integer division using CLP(Z). The divisor must be non-zero. 'div'(X, Y, Result) :- euclidean_division(X, Y, Result, _). %% 'mod'(+X, +Y, -Result) is nondet. % % Integer modulus using CLP(Z). The divisor must be non-zero. 'mod'(X, Y, Result) :- euclidean_division(X, Y, _, Result). col_array(_, arr([], _), _) :- throw_apl_error(rank_too_low(col, [])). col_array(_, arr([Rows], _), _) :- throw_apl_error(rank_too_low(col, [Rows])). col_array(Index, arr([Rows, Cols|Tail], Data), arr([Rows|Tail], Flat)) :- ( Index < Cols -> major_cells([Cols|Tail], Data, RowCells), column_cells(Index, RowCells, ColCells), flatten_cells(ColCells, Flat) ; throw_apl_error(index_out_of_range(col, Index, Cols)) ). column_cells(_, [], []). column_cells(Index, [Row|Rows], [Cell|Cells]) :- leading_axis_cell(Index, Row, Cell), column_cells(Index, Rows, Cells). leading_axis_cell(Index, arr([Count|Dims], Data), arr(Dims, CellData)) :- ( Index < Count -> major_cells(Dims, Data, Cells), nth0_exact(Index, Cells, arr(Dims, CellData)) ; throw_apl_error(index_out_of_range(col, Index, Count)) ). transpose_array(arr([], [Value]), arr([], [Value])) :- !. transpose_array(arr([N], Data), arr([N], Data)) :- !. transpose_array(arr([Rows, Cols|Tail], Data), arr([Cols, Rows|Tail], Flat)) :- major_cells([Cols|Tail], Data, RowCells), transpose_columns(0, Cols, Tail, RowCells, Columns), flatten_cells(Columns, Flat). transpose_columns(Index, Cols, _, _, []) :- Index >= Cols, !. transpose_columns(Index, Cols, Tail, RowCells, [arr([Rows|Tail], ColumnData)|Columns]) :- Index < Cols, column_cells(Index, RowCells, Cells), length(RowCells, Rows), flatten_cells(Cells, ColumnData), Index1 is Index + 1, transpose_columns(Index1, Cols, Tail, RowCells, Columns). truthy_indices([], _, []). truthy_indices([Value|Values], Index0, Indices) :- Index1 is Index0 + 1, truthy_indices(Values, Index1, Rest), ( truthy_mask(Value) -> Indices = [Index0|Rest] ; Indices = Rest ). euclidean_division(X, Y, Quotient, Remainder) :- ( Y #> 0, X #= Y * Quotient + Remainder, Remainder #>= 0, Remainder #< Y ; Y #< 0, X #= Y * Quotient + Remainder, Remainder #>= 0, NegY #= -Y, Remainder #< NegY ). % ============================================================================ % Validation helpers % ============================================================================ require_integer(_, N) :- integer(N), !. require_integer(_, N) :- var(N), !, throw(error(instantiation_error, N)). require_integer(_, N) :- throw(error(type_error(integer, N), _)). require_nonneg_integer(_, N) :- integer(N), N >= 0, !. require_nonneg_integer(_, N) :- integer(N), !, throw(error(domain_error(not_less_than_zero, N), _)). require_nonneg_integer(_, N) :- var(N), !, throw(error(instantiation_error, N)). require_nonneg_integer(_, N) :- throw(error(type_error(integer, N), _)). require_integer_list(_, []). require_integer_list(Context, [X|Xs]) :- require_nonneg_integer(Context, X), require_integer_list(Context, Xs). require_reshape_data(_, 0, _) :- !. require_reshape_data(_, _, [_|_]) :- !. require_reshape_data(Shape, _, []) :- throw_apl_error(cannot_reshape_empty_data(Shape)). ensure_same_shape(_, Shape, Shape). ensure_same_shape(Context, Expected, Actual) :- throw_apl_error(shape_mismatch(Context, Expected, Actual)). throw_apl_error(Term) :- throw(error(apl_error(Term), _)). % ============================================================================ % Input handling % ============================================================================ input_chars(Input, Chars) :- ( atom(Input) -> atom_chars(Input, Chars) ; proper_char_list(Input) -> Chars = Input ; throw(error(type_error(apl_input, Input), _)) ). proper_char_list([]). proper_char_list([C|Cs]) :- atom(C), atom_chars(C, [_]), proper_char_list(Cs). list_prefix([], Tail, Tail). list_prefix([X|Xs], [X|Ys], Tail) :- list_prefix(Xs, Ys, Tail).