-- Lua 5.3.5
-- Retrieved from: https://devforum.roblox.com/t/more-efficient-way-to-implement-shunting-yard/1328711
-- Modified slightly to ensure conformity with other code snippets posted here
local OPERATOR_PRECEDENCE = {
    -- [operator] = { [precedence], [is left assoc.] }
    ['-'] = { 2, true };
    ['+'] = { 2, true };
    ['/'] = { 3, true };
    ['*'] = { 3, true };
    ['^'] = { 4, false };
}

local function shuntingYard(expression)
    local outputQueue = { }
    local operatorStack = { }

    local number, operator, parenthesis, fcall

    while #expression > 0 do
        local nStartPos, nEndPos = string.find(expression, '(%-?%d+%.?%d*)')

        if nStartPos == 1 and nEndPos > 0 then
            number, expression = string.sub(expression, nStartPos, nEndPos), string.sub(expression, nEndPos + 1)
            table.insert(outputQueue, tonumber(number))

            print('token:', number)
            print('queue:', unpack(outputQueue))
            print('stack:', unpack(operatorStack))
        else
            local oStartPos, oEndPos = string.find(expression, '([%-%+%*/%^])')

            if oStartPos == 1 and oEndPos > 0 then
                operator, expression = string.sub(expression, oStartPos, oEndPos), string.sub(expression, oEndPos + 1)

                if #operatorStack > 0 then
                    while operatorStack[1] ~= '(' do
                        local operator1Precedence = OPERATOR_PRECEDENCE[operator]
                        local operator2Precedence = OPERATOR_PRECEDENCE[operatorStack[1]]

                        if operator2Precedence and ((operator2Precedence[1] > operator1Precedence[1]) or (operator2Precedence[1] == operator1Precedence[1] and operator1Precedence[2])) then
                            table.insert(outputQueue, table.remove(operatorStack, 1))
                        else
                           break
                        end
                    end
                end

                table.insert(operatorStack, 1, operator)

                print('token:', operator)
                print('queue:', unpack(outputQueue))
                print('stack:', unpack(operatorStack))
            else
                local pStartPos, pEndPos = string.find(expression, '[%(%)]')

                if pStartPos == 1 and pEndPos > 0 then
                    parenthesis, expression = string.sub(expression, pStartPos, pEndPos), string.sub(expression, pEndPos + 1)

                    if parenthesis == ')' then
                        while operatorStack[1] ~= '(' do
                            assert(#operatorStack > 0)
                            table.insert(outputQueue, table.remove(operatorStack, 1))
                        end

                        assert(operatorStack[1] == '(')
                        table.remove(operatorStack, 1)
                    else
                        table.insert(operatorStack, 1, parenthesis)
                    end

                    print('token:', parenthesis)
                    print('queue:', unpack(outputQueue))
                    print('stack:', unpack(operatorStack))
                else
                    local wStartPos, wEndPos = string.find(expression, '%s+')

                    if wStartPos == 1 and wEndPos > 0 then
                        expression = string.sub(expression, wEndPos + 1)
                    else
                        error('Invalid character set: '.. expression)
                    end
                end
            end
        end
    end

    while #operatorStack > 0 do
        assert(operatorStack[1] ~= '(')
        table.insert(outputQueue, table.remove(operatorStack, 1))
    end

    return table.concat(outputQueue, ' ')
end

local goodmath = '3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3'

print('infix:', goodmath)
print('postfix:', shuntingYard(goodmath))


rpn[str_] :=
  StringRiffle[
   ToString /@
    Module[{in = StringSplit[str], stack = {}, out = {}, next},
     While[in != {}, next = in[[1]]; in = in[[2 ;;]];
      Which[DigitQ[next], AppendTo[out, next], LetterQ[next],
       AppendTo[stack, next], next == ",",
       While[stack[[-1]] != "(", AppendTo[out, stack[[-1]]];
        stack = stack[[;; -2]]], next == "^", AppendTo[stack, "^"],
       next == "*",
       While[stack != {} && MatchQ[stack[[-1]], "^" | "*" | "/"],
        AppendTo[out, stack[[-1]]]; stack = stack[[;; -2]]];
       AppendTo[stack, "*"], next == "/",
       While[stack != {} && MatchQ[stack[[-1]], "^" | "*" | "/"],
        AppendTo[out, stack[[-1]]]; stack = stack[[;; -2]]];
       AppendTo[stack, "/"], next == "+",
       While[stack != {} &&
         MatchQ[stack[[-1]], "^" | "*" | "/" | "+" | "-"],
        AppendTo[out, stack[[-1]]]; stack = stack[[;; -2]]];
       AppendTo[stack, "+"], next == "-",
       While[stack != {} &&
         MatchQ[stack[[-1]], "^" | "*" | "/" | "+" | "-"],
        AppendTo[out, stack[[-1]]]; stack = stack[[;; -2]]];
       AppendTo[stack, "-"], next == "(", AppendTo[stack, "("],
       next == ")",
       While[stack[[-1]] =!= "(", AppendTo[out, stack[[-1]]];
        stack = stack[[;; -2]]]; stack = stack[[;; -2]];
       If[StringQ[stack[[-1]]], AppendTo[out, stack[[-1]]];
        stack = stack[[;; -2]]]]];
     While[stack != {}, AppendTo[out, stack[[-1]]];
      stack = stack[[;; -2]]]; out]];
Print[rpn["3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3"]];


import tables, strutils, strformat

type operator = tuple[prec:int, rassoc:bool]

let ops = newTable[string, operator](
  [ ("^", (4, true )),
    ("*", (3, false)),
    ("/", (3, false)),
    ("+", (2, false)),
    ("-", (2, false)) ])

proc shuntRPN(tokens:seq[string]): string =
  var stack: seq[string]
  var op:string

  for token in tokens:
    case token
    of "(": stack.add token
    of ")":
      while stack.len > 0:
        op = stack.pop()
        if op == "(": break
        result &= op & " "
    else:
      if token in ops:
        while stack.len > 0:
          op = stack[^1]  # peek stack top
          if not (op in ops): break
          if ops[token].prec > ops[op].prec or (ops[token].rassoc and (ops[token].prec == ops[op].prec)):
            break
          discard stack.pop()
          result &= op & " "
        stack.add token
      else:
        result &= token & " "
    echo fmt"""{token:5}   {join(stack," "):18} {result:25} """

  while stack.len > 0:
    result &= stack.pop() & " "
    echo fmt"""        {join(stack," "):18} {result:25} """

let input = "3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3"

echo &"for infix expression: '{input}' \n", "\nTOKEN   OP STACK           RPN OUTPUT"
echo "postfix: ", shuntRPN(input.strip.split)


type associativity = Left | Right;;

let prec op =
  match op with
  | "^" -> 4
  | "*" -> 3
  | "/" -> 3
  | "+" -> 2
  | "-" -> 2
  | _ -> -1;;

let assoc op =
  match op with
  | "^" -> Right
  | _ -> Left;;

let split_while p =
  let rec go ls xs =
    match xs with
    | x::xs' when p x -> go (x::ls) xs'
    | _ -> List.rev ls, xs
  in go [];;

let rec intercalate sep xs =
  match xs with
  | [] -> ""
  | [x] -> x
  | x::xs' -> x ^ sep ^ intercalate sep xs';;

let shunting_yard =
  let rec pusher stack queue tkns =
    match tkns with
    | [] -> List.rev queue @ stack
    | "("::tkns' -> pusher ("("::stack) queue tkns'
    | ")"::tkns' ->
        let mv, "("::stack' = split_while ((<>) "(") stack in
        pusher stack' (mv @ queue) tkns'
    | t::tkns' when prec t < 0 -> pusher stack (t::queue) tkns'
    | op::tkns' ->
        let mv_to_queue op2 =
          (match assoc op with
            | Left -> prec op <= prec op2
            | Right -> prec op < prec op2)
        in
        let mv, stack' = split_while mv_to_queue stack in
        pusher (op::stack') (mv @ queue) tkns'
  in pusher [] [];;

let () =
  let inp = read_line () in
  let tkns = String.split_on_char ' ' inp in
  let postfix = shunting_yard tkns in
  print_endline (intercalate " " postfix);;


my %prec = (
    '^' => 4,
    '*' => 3,
    '/' => 3,
    '+' => 2,
    '-' => 2,
    '(' => 1
);

my %assoc = (
    '^' => 'right',
    '*' => 'left',
    '/' => 'left',
    '+' => 'left',
    '-' => 'left'
);

sub shunting_yard {
    my @inp = split ' ', $_[0];
    my @ops;
    my @res;

    my $report = sub { printf "%25s    %-7s %10s %s\n", "@res", "@ops", $_[0], "@inp" };
    my $shift  = sub { $report->("shift @_");  push @ops, @_ };
    my $reduce = sub { $report->("reduce @_"); push @res, @_ };

    while (@inp) {
        my $token = shift @inp;
        if    ( $token =~ /\d/ ) { $reduce->($token) }
        elsif ( $token eq '(' )  { $shift->($token) }
        elsif ( $token eq ')' ) {
            while ( @ops and "(" ne ( my $x = pop @ops ) ) { $reduce->($x) }
        } else {
            my $newprec = $prec{$token};
            while (@ops) {
                my $oldprec = $prec{ $ops[-1] };
                last if $newprec > $oldprec;
                last if $newprec == $oldprec and $assoc{$token} eq 'right';
                $reduce->( pop @ops );
            }
            $shift->($token);
        }
    }
    $reduce->( pop @ops ) while @ops;
    @res;
}

local $, = " ";
print shunting_yard '3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3';


with javascript_semantics
bool show_workings = true

constant operators  = {"^","*","/","+","-"},
         precedence = { 4,  3,  3,  2,  2 }

procedure shunting_yard(string infix, rpn)
    string res = "", sep = "", stack_top
    sequence stack = {},
             ops = split(substitute_all(infix,{"(",")"},{" ( "," ) "}),' ')
    printf(1,"Infix input: %-32s%s", {infix,iff(show_workings?'\n':' ')})
    for i=1 to length(ops) do
        string op = ops[i]
        if op="(" then
            stack = append(stack,op)
        elsif op=")" then
            while 1 do
                stack_top = stack[$]
                stack = stack[1..$-1]
                if stack_top="(" then exit end if
                res &= sep&stack_top
                sep = " "
            end while
        else
            integer k = find(op,operators)
            if k!=0 then
                integer prec = precedence[k]
                while length(stack) do
                    stack_top = stack[$]
                    k = find(stack_top,operators)
                    if k=0 or prec>precedence[k]
                          or (prec=precedence[k] and stack_top="^") then
                        exit
                    end if
                    stack = stack[1..$-1]
                    res &= sep&stack_top
                    sep = " "
                end while
                stack = append(stack,op)
            else
                res &= sep&op
                sep = " "
            end if
        end if
        if show_workings then
            ?{op,stack,res}
        end if
    end for
    for i=length(stack) to 1 by -1 do
        string op = stack[i]
        res &= sep&op
        sep = " "
    end for
    printf(1,"result: %-22s [%s]\n", {res,iff(res=rpn?"ok","**ERROR**")})
end procedure

shunting_yard("3 + 4 * 2 / (1 - 5) ^ 2 ^ 3","3 4 2 * 1 5 - 2 3 ^ ^ / +")
show_workings = false
shunting_yard("((1 + 2) ^ (3 + 4)) ^ (5 + 6)","1 2 + 3 4 + ^ 5 6 + ^")
shunting_yard("(1 + 2) ^ (3 + 4) ^ (5 + 6)","1 2 + 3 4 + 5 6 + ^ ^")
shunting_yard("((3 ^ 4) ^ 2 ^ 9) ^ 2 ^ 5","3 4 ^ 2 9 ^ ^ 2 5 ^ ^")
shunting_yard("(1 + 4) * (5 + 3) * 2 * 3","1 4 + 5 3 + * 2 * 3 *")
shunting_yard("1 * 2 * 3 * 4","1 2 * 3 * 4 *")
shunting_yard("1 + 2 + 3 + 4","1 2 + 3 + 4 +")
shunting_yard("(1 + 2) ^ (3 + 4)","1 2 + 3 4 + ^")
shunting_yard("(5 ^ 6) ^ 7","5 6 ^ 7 ^")
shunting_yard("5 ^ 4 ^ 3 ^ 2","5 4 3 2 ^ ^ ^")
shunting_yard("1 + 2 + 3","1 2 + 3 +")
shunting_yard("1 ^ 2 ^ 3","1 2 3 ^ ^")
shunting_yard("(1 ^ 2) ^ 3","1 2 ^ 3 ^")
shunting_yard("1 - 1 + 3","1 1 - 3 +")
shunting_yard("3 + 1 - 1","3 1 + 1 -")
shunting_yard("1 - (2 + 3)","1 2 3 + -")
shunting_yard("4 + 3 + 2","4 3 + 2 +")
shunting_yard("5 + 4 + 3 + 2","5 4 + 3 + 2 +")
shunting_yard("5 * 4 * 3 * 2","5 4 * 3 * 2 *")
shunting_yard("5 + 4 - (3 + 2)","5 4 + 3 2 + -")
shunting_yard("3 - 4 * 5","3 4 5 * -")
shunting_yard("3 * (4 - 5)","3 4 5 - *")
shunting_yard("(3 - 4) * 5","3 4 - 5 *")
shunting_yard("4 * 2 + 1 - 5","4 2 * 1 + 5 -")
shunting_yard("4 * 2 / (1 - 5) ^ 2","4 2 * 1 5 - 2 ^ /")


(de operator (Op)
   (member Op '("\^" "*" "/" "+" "-")) )

(de leftAssoc (Op)
   (member Op '("*" "/" "+" "-")) )

(de precedence (Op)
   (case Op
      ("\^" 4)
      (("*" "/") 3)
      (("+" "-") 2) ) )

(de shuntingYard (Str)
   (make
      (let (Fmt (-7 -30 -4)  Stack)
         (tab Fmt "Token" "Output" "Stack")
         (for Token (str Str "_")
            (cond
               ((num? Token) (link @))
               ((= "(" Token) (push 'Stack Token))
               ((= ")" Token)
                  (until (= "(" (car Stack))
                     (unless Stack
                        (quit "Unbalanced Stack") )
                     (link (pop 'Stack)) )
                  (pop 'Stack) )
               (T
                  (while
                     (and
                        (operator (car Stack))
                        ((if (leftAssoc (car Stack)) <= <)
                           (precedence Token)
                           (precedence (car Stack)) ) )
                     (link (pop 'Stack)) )
                  (push 'Stack Token) ) )
            (tab Fmt Token (glue " " (made)) Stack) )
         (while Stack
            (when (= "(" (car Stack))
               (quit "Unbalanced Stack") )
            (link (pop 'Stack))
            (tab Fmt NIL (glue " " (made)) Stack) ) ) ) )


cvt: procedure options (main);               /* 15 January 2012. */
   declare (in, stack, out) character (100) varying;
   declare (ch, chs) character (1);
   declare display bit (1) static initial ('0'b);

   in = '3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3';

   in = '(' || in || ' ) ';             /* Initialize with parentheses */

   put skip edit ('INPUT', 'STACK', 'OUTPUT') (a, col(37), a, col(47), a);

   stack = ' '; out = ''; /* Initialize */
   do while (length (in) > 0);
      ch = substr(in, 1, 1);
      select (ch);
         when (' ') ;

         when ('+', '-', '*', '/', '^')
            do;
               /* Copy any equal or higher-priority operators from the stack */
               /* to the output string */
               chs = substr(stack, 1, 1);
               do while ((spriority(chs) >= priority(ch)) & ( chs ^= ')' ) );
                  if display then put skip list ('unstacking: ' || chs);
                  out = out || ' ' || chs;
                  stack = substr(stack, 2);
                  chs = substr(stack, 1, 1);
               end;
               /* Now copy the input to the TOS. */
               if display then put skip list ('copying ' || ch || ' to TOS');
               stack = ch || stack;
            end;
         when ( '(' )
            do;
               stack = '(' || stack;
               if display then put skip list ('stacking the (' );
            end;
         when ( ')' )
            do; /* copy all operators from the stack to the output, */
                /* until a '(' is encountered. */
               chs = substr(stack, 1, 1);
               do while (chs ^= '(' );
                  if display then put skip list ('copying stack ' || chs || ' to output');
                  put skip edit (stack, out) (col(37), a, col(47), a);
                  out = out || ' ' || chs;
                  stack = substr(stack, 2);
                  chs = substr(stack, 1, 1);
               end;
               /* Now delete the '(' from the input and */
               /* the ')' from the top of the stack. */
               if display then put skip edit ('Deleting ( from TOS') (col(30), a);
               stack = substr(stack, 2);
               /* The '(' on the input is removed at the end of the loop. */
            end;
         otherwise /* it's an operand. */
            do;
               out = out || ' ';
               do while (ch ^= ' ');
                  if display then put skip list ('copying ' || ch || ' to output');
                  out = out || ch;
                  in = substr(in, 2);
                  ch = substr(in, 1, 1);
               end;
            end;
      end;
      in = substr(in, 2); /* Remove one character from the input */
      put skip edit (in, stack, out) (a, col(37), a, col(47), a);
   end;

priority: procedure (ch) returns (character(1));
   declare ch character (1);

   return ( translate(ch, '1122335', '()+-*/^' ) );
end priority;

spriority: procedure (ch) returns (character(1));
   declare ch character (1);

   return ( translate(ch, '1122334', '()+-*/^' ) );
end spriority;

end cvt;


from collections import namedtuple
from pprint import pprint as pp

OpInfo = namedtuple('OpInfo', 'prec assoc')
L, R = 'Left Right'.split()

ops = {
 '^': OpInfo(prec=4, assoc=R),
 '*': OpInfo(prec=3, assoc=L),
 '/': OpInfo(prec=3, assoc=L),
 '+': OpInfo(prec=2, assoc=L),
 '-': OpInfo(prec=2, assoc=L),
 '(': OpInfo(prec=9, assoc=L),
 ')': OpInfo(prec=0, assoc=L),
 }

NUM, LPAREN, RPAREN = 'NUMBER ( )'.split()

def get_input(inp = None):
    'Inputs an expression and returns list of (TOKENTYPE, tokenvalue)'

    if inp is None:
        inp = input('expression: ')
    tokens = inp.strip().split()
    tokenvals = []
    for token in tokens:
        if token in ops:
            tokenvals.append((token, ops[token]))
        #elif token in (LPAREN, RPAREN):
        #    tokenvals.append((token, token))
        else:
            tokenvals.append((NUM, token))
    return tokenvals

def shunting(tokenvals):
    outq, stack = [], []
    table = ['TOKEN,ACTION,RPN OUTPUT,OP STACK,NOTES'.split(',')]
    for token, val in tokenvals:
        note = action = ''
        if token is NUM:
            action = 'Add number to output'
            outq.append(val)
            table.append( (val, action, ' '.join(outq), ' '.join(s[0] for s in stack), note) )
        elif token in ops:
            t1, (p1, a1) = token, val
            v = t1
            note = 'Pop ops from stack to output'
            while stack:
                t2, (p2, a2) = stack[-1]
                if (a1 == L and p1 <= p2) or (a1 == R and p1 < p2):
                    if t1 != RPAREN:
                        if t2 != LPAREN:
                            stack.pop()
                            action = '(Pop op)'
                            outq.append(t2)
                        else:
                            break
                    else:
                        if t2 != LPAREN:
                            stack.pop()
                            action = '(Pop op)'
                            outq.append(t2)
                        else:
                            stack.pop()
                            action = '(Pop & discard "(")'
                            table.append( (v, action, ' '.join(outq), ' '.join(s[0] for s in stack), note) )
                            break
                    table.append( (v, action, ' '.join(outq), ' '.join(s[0] for s in stack), note) )
                    v = note = ''
                else:
                    note = ''
                    break
                note = ''
            note = ''
            if t1 != RPAREN:
                stack.append((token, val))
                action = 'Push op token to stack'
            else:
                action = 'Discard ")"'
            table.append( (v, action, ' '.join(outq), ' '.join(s[0] for s in stack), note) )
    note = 'Drain stack to output'
    while stack:
        v = ''
        t2, (p2, a2) = stack[-1]
        action = '(Pop op)'
        stack.pop()
        outq.append(t2)
        table.append( (v, action, ' '.join(outq), ' '.join(s[0] for s in stack), note) )
        v = note = ''
    return table

if __name__ == '__main__':
    infix = '3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3'
    print( 'For infix expression: %r\n' % infix )
    rp = shunting(get_input(infix))
    maxcolwidths = [len(max(x, key=len)) for x in zip(*rp)]
    row = rp[0]
    print( ' '.join('{cell:^{width}}'.format(width=width, cell=cell) for (width, cell) in zip(maxcolwidths, row)))
    for row in rp[1:]:
        print( ' '.join('{cell:<{width}}'.format(width=width, cell=cell) for (width, cell) in zip(maxcolwidths, row)))

    print('\n The final output RPN is: %r' % rp[-1][2])


#lang racket
;print column of width w
(define (display-col w s)
  (let* ([n-spaces (- w (string-length s))]
         [spaces (make-string n-spaces #\space)])
    (display (string-append s spaces))))
;print columns given widths (idea borrowed from PicoLisp)
(define (tab ws . ss) (for-each display-col ws ss) (newline))

(define input "3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3")

(define (paren? s) (or (string=? s "(") (string=? s ")")))
(define-values (prec lasso? rasso? op?)
  (let ([table '(["^" 4 r]
                 ["*" 3 l]
                 ["/" 3 l]
                 ["+" 2 l]
                 ["-" 2 l])])
    (define (asso x) (caddr (assoc x table)))
    (values (λ (x) (cadr (assoc x table)))
            (λ (x) (symbol=? (asso x) 'l))
            (λ (x) (symbol=? (asso x) 'r))
            (λ (x) (member x (map car table))))))

(define (shunt s)
  (define widths (list 8 (string-length input) (string-length input) 20))
  (tab widths "TOKEN" "OUT" "STACK" "ACTION")
  (let shunt ([out '()] [ops '()] [in (string-split s)] [action ""])
    (match in
      ['() (if (memf paren? ops)
               (error "unmatched parens")
               (reverse (append (reverse ops) out)))]
      [(cons x in)
       (tab widths x (string-join (reverse out) " ") (string-append* ops) action)
       (match x
         [(? string->number n) (shunt (cons n out) ops in (format "out ~a" n))]
         ["(" (shunt out (cons "(" ops) in "push (")]
         [")" (let-values ([(l r) (splitf-at ops (λ (y) (not (string=? y "("))))])
                (match r
                  ['() (error "unmatched parens")]
                  [(cons _ r) (shunt (append (reverse l) out) r in "clear til )")]))]
         [else (let-values ([(l r) (splitf-at ops (λ (y) (and (op? y)
                                                              ((if (lasso? x) <= <) (prec x) (prec y)))))])
                 (shunt (append (reverse l) out) (cons x r) in (format "out ~a, push ~a" l x)))])])))


my %prec =
    '^' => 4,
    '*' => 3,
    '/' => 3,
    '+' => 2,
    '-' => 2,
    '(' => 1;

my %assoc =
    '^' => 'right',
    '*' => 'left',
    '/' => 'left',
    '+' => 'left',
    '-' => 'left';

sub shunting-yard ($prog) {
    my @inp = $prog.words;
    my @ops;
    my @res;

    sub report($op) { printf "%25s    %-7s %10s %s\n", ~@res, ~@ops, $op, ~@inp }
    sub shift($t)  { report( "shift $t"); @ops.push: $t }
    sub reduce($t) { report("reduce $t"); @res.push: $t }

    while @inp {
	given @inp.shift {
	    when /\d/ { reduce $_ };
	    when '(' { shift $_ }
	    when ')' { while @ops and (my $x = @ops.pop and $x ne '(') { reduce $x } }
	    default {
		my $newprec = %prec{$_};
		while @ops {
		    my $oldprec = %prec{@ops[*-1]};
		    last if $newprec > $oldprec;
		    last if $newprec == $oldprec and %assoc{$_} eq 'right';
		    reduce @ops.pop;
		}
		shift $_;
	    }
	}
    }
    reduce @ops.pop while @ops;
    @res;
}

say shunting-yard '3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3';


/*REXX pgm converts infix arith. expressions to Reverse Polish notation (shunting─yard).*/
parse arg x                                      /*obtain optional argument from the CL.*/
if x=''  then x= '3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3' /*Not specified?  Then use the default.*/
ox=x
x='(' space(x) ") "                              /*force stacking for the expression.   */
#=words(x)                                       /*get number of tokens in expression.  */
              do i=1  for #;   @.i=word(x, i)    /*assign the input tokens to an array. */
              end   /*i*/
tell=1                                           /*set to 0 if working steps not wanted.*/
L=max( 20, length(x) )                           /*use twenty for the minimum show width*/

say  'token'  center("input" , L, '─')     center("stack" , L%2, '─'),
              center("output", L, '─')     center("action", L,   '─')
op= ")(-+/*^";   Rop=substr(op,3);   p.=;  n=length(op);  RPN=  /*some handy-dandy vars.*/
s.=
   do i=1  for n;  _=substr(op,i,1);  s._=(i+1)%2;   p._=s._+(i==n);  end  /*i*/
$=                                               /* [↑]  assign the operator priorities.*/
   do k=1  for #;              [email protected].k             /*process each token from the  @. list.*/
     select                                      /*@.k is:  (,  operator,   ),   operand*/
     when ?=='('   then do; $="(" $;    call show 'moving'   ?   "──► stack";    end
     when isOp(?)  then do;              !=word($, 1)             /*get token from stack*/
                               do  while ! \==')'  &  s.!>=p.?
                               RPN=RPN !                          /*add token  to   RPN.*/
                               $=subword($, 2)                    /*del token from stack*/
                               call show 'unstacking:'  !
                               !=word($, 1)                       /*get token from stack*/
                               end   /*while*/
                        $=? $                                     /*add token  to  stack*/
                        call show 'moving'   ?   "──► stack"
                        end
     when ?==')'   then do;             !=word($, 1)              /*get token from stack*/
                             do  while  !\=='(';     RPN=RPN !    /*add token  to  RPN. */
                             $=subword($, 2)                      /*del token from stack*/
                             !=   word($, 1)                      /*get token from stack*/
                             call show 'moving stack' ! "──► RPN"
                             end   /*while*/
                        $=subword($, 2)                           /*del token from stack*/
                        call show 'deleting ( from the stack'
                        end
     otherwise  RPN=RPN ?                                         /*add operand to RPN. */
                call show 'moving'     ?     "──► RPN"
    end   /*select*/
   end    /*k*/
say
RPN=space(RPN $)                                 /*elide any superfluous blanks in RPN. */
say ' input:'  ox;     say " RPN──►"    RPN      /*display the input  and  the RPN.     */
parse source upper . y .                         /*invoked via the  C.L.  or  REXX pgm? */
if y=='COMMAND'  then  exit                      /*stick a fork in it,  we're all done. */
                 else  return RPN                /*return RPN to invoker  (the RESULT). */
/*──────────────────────────────────────────────────────────────────────────────────────────*/
isOp: return pos(arg(1),rOp) \== 0               /*is the first argument a "real" operator? */
show: if tell then say center(?,5) left(subword(x,k),L) left($,L%2) left(RPN,L) arg(1); return


rpn = RPNExpression.from_infix("3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3")


type Number = f64;

#[derive(Debug, Copy, Clone, PartialEq)]
struct Operator {
    token: char,
    operation: fn(Number, Number) -> Number,
    precedence: u8,
    is_left_associative: bool,
}

#[derive(Debug, Clone, PartialEq)]
enum Token {
    Digit(Number),
    Operator(Operator),
    LeftParen,
    RightParen,
}

impl Operator {
    fn new_token(
        token: char,
        precedence: u8,
        is_left_associative: bool,
        operation: fn(Number, Number) -> Number,
    ) -> Token {
        Token::Operator(Operator {
            token: token,
            operation: operation,
            precedence: precedence,
            is_left_associative,
        })
    }

    fn apply(&self, x: Number, y: Number) -> Number {
        (self.operation)(x, y)
    }
}

trait Stack<T> {
    fn top(&self) -> Option<T>;
}

impl<T: Clone> Stack<T> for Vec<T> {
    fn top(&self) -> Option<T> {
        if self.is_empty() {
            return None;
        }
        self.last().cloned()
    }
}
fn lex_token(input: char) -> Result<Token, char> {
    let ret = match input {
        '0'...'9' => Token::Digit(input.to_digit(10).unwrap() as Number),
        '+' => Operator::new_token('+', 1, true, |x, y| x + y),
        '-' => Operator::new_token('-', 1, true, |x, y| x - y),
        '*' => Operator::new_token('*', 2, true, |x, y| x * y),
        '/' => Operator::new_token('/', 2, true, |x, y| x / y),
        '^' => Operator::new_token('^', 3, false, |x, y| x.powf(y)),
        '(' => Token::LeftParen,
        ')' => Token::RightParen,
        _ => return Err(input),
    };
    Ok(ret)
}

fn lex(input: String) -> Result<Vec<Token>, char> {
    input
        .chars()
        .filter(|c| !c.is_whitespace())
        .map(lex_token)
        .collect()
}

fn tilt_until(operators: &mut Vec<Token>, output: &mut Vec<Token>, stop: Token) -> bool {
    while let Some(token) = operators.pop() {
        if token == stop {
            return true;
        }
        output.push(token)
    }
    false
}

fn shunting_yard(tokens: Vec<Token>) -> Result<Vec<Token>, String> {
    let mut output: Vec<Token> = Vec::new();
    let mut operators: Vec<Token> = Vec::new();

    for token in tokens {
        match token {
            Token::Digit(_) => output.push(token),
            Token::LeftParen => operators.push(token),
            Token::Operator(operator) => {
                while let Some(top) = operators.top() {
                    match top {
                        Token::LeftParen => break,
                        Token::Operator(top_op) => {
                            let p = top_op.precedence;
                            let q = operator.precedence;
                            if (p > q) || (p == q && operator.is_left_associative) {
                                output.push(operators.pop().unwrap());
                            } else {
                                break;
                            }
                        }
                        _ => unreachable!("{:?} must not be on operator stack", token),
                    }
                }
                operators.push(token);
            }
            Token::RightParen => {
                if !tilt_until(&mut operators, &mut output, Token::LeftParen) {
                    return Err(String::from("Mismatched ')'"));
                }
            }
        }
    }

    if tilt_until(&mut operators, &mut output, Token::LeftParen) {
        return Err(String::from("Mismatched '('"));
    }

    assert!(operators.is_empty());
    Ok(output)
}

fn calculate(postfix_tokens: Vec<Token>) -> Result<Number, String> {
    let mut stack = Vec::new();

    for token in postfix_tokens {
        match token {
            Token::Digit(number) => stack.push(number),
            Token::Operator(operator) => {
                if let Some(y) = stack.pop() {
                    if let Some(x) = stack.pop() {
                        stack.push(operator.apply(x, y));
                        continue;
                    }
                }
                return Err(format!("Missing operand for operator '{}'", operator.token));
            }
            _ => unreachable!("Unexpected token {:?} during calculation", token),
        }
    }

    assert!(stack.len() == 1);
    Ok(stack.pop().unwrap())
}

fn run(input: String) -> Result<Number, String> {
    let tokens = match lex(input) {
        Ok(tokens) => tokens,
        Err(c) => return Err(format!("Invalid character: {}", c)),
    };
    let postfix_tokens = match shunting_yard(tokens) {
        Ok(tokens) => tokens,
        Err(message) => return Err(message),
    };

    calculate(postfix_tokens)
}


var prec = Hash(
    '^' => 4,
    '*' => 3,
    '/' => 3,
    '+' => 2,
    '-' => 2,
    '(' => 1,
)

var assoc = Hash(
    '^' => 'right',
    '*' => 'left',
    '/' => 'left',
    '+' => 'left',
    '-' => 'left',
)

func shunting_yard(prog) {
    var inp = prog.words
    var ops = []
    var res = []

    func report (op) {
        printf("%25s    %-7s %10s %s\n",
            res.join(' '), ops.join(' '), op, inp.join(' '))
    }

    func shift  (t)  { report( "shift #{t}"); ops << t }
    func reduce (t)  { report("reduce #{t}"); res << t }

    while (inp) {
        given(var t = inp.shift) {
           when (/\d/) { reduce(t) }
           when ('(')  { shift(t) }
           when (')')  {
               while (ops) {
                 (var x = ops.pop) == '(' ? break : reduce(x)
               }
           }
           default {
                var newprec = prec{t}
                while (ops) {
                    var oldprec = prec{ops[-1]}

                    break if (newprec > oldprec)
                    break if ((newprec == oldprec) && (assoc{t} == 'right'))

                    reduce(ops.pop)
                }
                shift(t)
            }
        }
    }
    while (ops) { reduce(ops.pop) }
    return res
}

say shunting_yard('3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3').join(' ')


structure Operator = struct
  datatype associativity = LEFT | RIGHT
  type operator = { symbol : char, assoc : associativity, precedence : int }

  val operators : operator list = [
    { symbol = #"^", precedence = 4, assoc = RIGHT },
    { symbol = #"*", precedence = 3, assoc = LEFT },
    { symbol = #"/", precedence = 3, assoc = LEFT },
    { symbol = #"+", precedence = 2, assoc = LEFT },
    { symbol = #"-", precedence = 2, assoc = LEFT }
  ]

  fun find (c : char) : operator option = List.find (fn ({symbol, ...} : operator) => symbol = c) operators

  infix cmp
  fun ({precedence=p1, assoc=a1, ...} : operator) cmp ({precedence=p2, ...} : operator) =
    case a1 of
      LEFT => p1 <= p2
    | RIGHT => p1 < p2
end

signature SHUNTING_YARD = sig
  type 'a tree
  type content

  val parse : string -> content tree
end

structure ShuntingYard : SHUNTING_YARD = struct
  structure O = Operator
  val cmp = O.cmp
  (* did you know infixity doesn't "carry out" of a structure unless you open it? TIL *)
  infix cmp
  fun pop2 (b::a::rest) = ((a, b), rest)
    | pop2 _ = raise Fail "bad input"

  datatype content = Op of char
                   | Int of int
  datatype 'a tree = Leaf
                   | Node of 'a tree * 'a * 'a tree

  fun parse_int' tokens curr = case tokens of
      [] => (List.rev curr, [])
    | t::ts => if Char.isDigit t then parse_int' ts (t::curr)
               else (List.rev curr, t::ts)

  fun parse_int tokens = let
    val (int_chars, rest) = parse_int' tokens []
  in
    ((Option.valOf o Int.fromString o String.implode) int_chars, rest)
  end

  fun parse (s : string) : content tree = let
    val tokens = String.explode s
    (* parse': tokens operator_stack trees *)
    fun parse' [] [] [result] = result
      | parse' [] (opr::os) trees =
          if opr = #"(" orelse opr = #")" then raise Fail "bad input"
          else let
            val ((a,b), trees') = pop2 trees
            val trees'' = (Node (a, Op opr, b)) :: trees'
          in
            parse' [] os trees''
          end
      | parse' (t::ts) operators trees =
          if Char.isSpace t then parse' ts operators trees else
          if t = #"(" then parse' ts (t::operators) (trees : content tree list) else
          if t = #")" then let
            (* process_operators : operators trees *)
            fun process_operators [] _ = raise Fail "bad input"
              | process_operators (opr::os) trees =
                  if opr = #"(" then (os, trees)
                  else let
                    val ((a, b), trees') = pop2 trees
                    val trees'' = (Node (a, Op opr, b)) :: trees'
                  in
                    process_operators os trees''
                  end
            val (operators', trees') = process_operators (operators : char list) (trees : content tree list)
          in
            parse' ts operators' trees'
          end else
          (case O.find (t : char) of
            SOME o1 => let
              (* process_operators : operators trees *)
              fun process_operators [] trees = ([], trees)
                | process_operators (o2::os) trees = (case O.find o2 of
                    SOME o2 =>
                      if o1 cmp o2 then let
                        val ((a, b), trees') = pop2 trees
                        val trees'' = (Node (a, Op (#symbol o2), b)) :: trees'
                      in
                        process_operators os trees''
                      end
                      else ((#symbol o2)::os, trees)
                  | NONE => (o2::os, trees))
              val (operators', trees') = process_operators operators trees
            in
              parse' ts ((#symbol o1)::operators') trees'
            end
          | NONE => let
              val (n, tokens') = parse_int (t::ts)
            in
              parse' tokens' operators ((Node (Leaf, Int n, Leaf)) :: trees)
            end)
      | parse' _ _ _ = raise Fail "bad input"
  in
    parse' tokens [] []
  end
end


import Foundation

// Using arrays for both stack and queue
struct Stack<T> {
    private(set) var elements = [T]()
    var isEmpty: Bool { return elements.isEmpty }

    mutating func push(newElement: T) {
        elements.append(newElement)
    }

    mutating func pop() -> T {
        return elements.removeLast()
    }

    func top() -> T? {
        return elements.last
    }
}

struct Queue<T> {
    private(set) var elements = [T]()
    var isEmpty: Bool { return elements.isEmpty }

    mutating func enqueue(newElement: T) {
        elements.append(newElement)
    }

    mutating func dequeue() -> T {
        return elements.removeFirst()
    }
}

enum Associativity { case Left, Right }

// Define abstract interface, which can be used to restrict Set extension
protocol OperatorType: Comparable, Hashable {
    var name: String { get }
    var precedence: Int { get }
    var associativity: Associativity { get }
}

struct Operator: OperatorType {
    let name: String
    let precedence: Int
    let associativity: Associativity
    // same operator names are not allowed
    var hashValue: Int { return "\(name)".hashValue }

    init(_ name: String, _ precedence: Int, _ associativity: Associativity) {
        self.name = name; self.precedence = precedence; self.associativity = associativity
    }
}

func ==(x: Operator, y: Operator) -> Bool {
    // same operator names are not allowed
    return x.name == y.name
}

func <(x: Operator, y: Operator) -> Bool {
    // compare operators by their precedence and associavity
    return (x.associativity == .Left && x.precedence == y.precedence) || x.precedence < y.precedence
}

extension Set where Element: OperatorType {
    func contains(op: String?) -> Bool {
        guard let operatorName = op else { return false }
        return contains { $0.name == operatorName }
    }

    subscript (operatorName: String) -> Element? {
        get {
            return filter { $0.name == operatorName }.first
        }
    }
}

// Convenience
extension String {
    var isNumber: Bool { return Double(self) != nil }
}

struct ShuntingYard {
    enum Error: ErrorType {
        case MismatchedParenthesis(String)
        case UnrecognizedToken(String)
    }

    static func parse(input: String, operators: Set<Operator>) throws -> String {
        var stack = Stack<String>()
        var output = Queue<String>()
        let tokens = input.componentsSeparatedByString(" ")

        for token in tokens {
            // Wikipedia: if token is a number add it to the output queue
            if token.isNumber {
                output.enqueue(token)
            }
            // Wikipedia: else if token is a operator:
            else if operators.contains(token) {
                // Wikipedia: while there is a operator on top of the stack and has lower precedence than current operator (token)
                while operators.contains(stack.top()) && hasLowerPrecedence(token, stack.top()!, operators) {
                    // Wikipedia: pop it off to the output queue
                    output.enqueue(stack.pop())
                }
                // Wikipedia: push current operator (token) onto the operator stack
                stack.push(token)
            }
            // Wikipedia: If the token is a left parenthesis, then push it onto the stack.
            else if token == "(" {
                stack.push(token)
            }
            // Wikipedia: If the token is a right parenthesis:
            else if token == ")" {
                // Wikipedia: Until the token at the top of the stack is a left parenthesis
                while !stack.isEmpty && stack.top() != "(" {
                    // Wikipedia: pop operators off the stack onto the output queue.
                    output.enqueue(stack.pop())
                }

                // If the stack runs out, than there are mismatched parentheses.
                if stack.isEmpty {
                    throw Error.MismatchedParenthesis(input)
                }

                // Wikipedia: Pop the left parenthesis from the stack, but not onto the output queue.
                stack.pop()
            }
            // if token is not number, operator or a parenthesis, then is not recognized
            else {
                throw Error.UnrecognizedToken(token)
            }
        }

        // Wikipedia: When there are no more tokens to read:

        // Wikipedia: While there are still operator tokens in the stack:
        while operators.contains(stack.top()) {
            // Wikipedia: Pop the operator onto the output queue.
            output.enqueue(stack.pop())
        }

        // Wikipedia: If the operator token on the top of the stack is a parenthesis, then there are mismatched parentheses
        // Note: Assume that all operators has been poped onto the output queue.
        if stack.isEmpty == false {
            throw Error.MismatchedParenthesis(input)
        }

        return output.elements.joinWithSeparator(" ")
    }

    static private func containsOperator(stack: Stack<String>, _ operators: [String: NSDictionary]) -> Bool {
        guard stack.isEmpty == false else { return false }
        // Is there a matching operator in the operators set?
        return operators[stack.top()!] != nil ? true : false
    }

    static private func hasLowerPrecedence(x: String, _ y: String, _ operators: Set<Operator>) -> Bool {
        guard let first = operators[x], let second = operators[y] else { return false }
        return first < second
    }
}

let input = "3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3"
let operators: Set<Operator> = [
    Operator("^", 4, .Right),
    Operator("*", 3, .Left),
    Operator("/", 3, .Left),
    Operator("+", 2, .Left),
    Operator("-", 2, .Left)
]
let output = try! ShuntingYard.parse(input, operators: operators)

print("input: \(input)")
print("output: \(output)")


package require Tcl 8.5

# Helpers
proc tokenize {str} {
    regexp -all -inline {[\d.]+|[-*^+/()]} $str
}
proc precedence op {
    dict get {^ 4 * 3 / 3 + 2 - 2} $op
}
proc associativity op {
    if {$op eq "^"} {return "right"} else {return "left"}
}

proc shunting {expression} {
    set stack {}
    foreach token [tokenize $expression] {
	if {[string is double $token]} {
	    puts "add to output: $token"
	    lappend output $token
	} elseif {$token eq "("} {
	    puts "push parenthesis"
	    lappend stack $token
	} elseif {$token eq ")"} {
	    puts "popping to parenthesis"
	    while {[lindex $stack end] ne "("} {
		lappend output [lindex $stack end]
		set stack [lreplace $stack end end]
		puts "...popped [lindex $output end] to output"
	    }
	    set stack [lreplace $stack end end]
	    puts "...found parenthesis"
	} else {
	    puts "adding operator: $token"
	    set p [precedence $token]
	    set a [associativity $token]
	    while {[llength $stack]} {
		set o2 [lindex $stack end]
		if {
		    $o2 ne "(" &&
		    (($a eq "left" && $p <= [precedence $o2]) ||
		    ($a eq "right" && $p < [precedence $o2]))
		} then {
		    puts "...popped operator $o2 to output"
		    lappend output $o2
		    set stack [lreplace $stack end end]
		} else {
		    break
		}
	    }
	    lappend stack $token
	}
	puts "\t\tOutput:\t$output\n\t\tStack:\t$stack"
    }
    puts "transferring tokens from stack to output"
    lappend output {*}[lreverse $stack]
}

puts [shunting "3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3"]


#!/bin/sh

getopprec() {
    case "$1" in
        '+') echo 2;;
        '-') echo 2;;
        '*') echo 3;;
        '/') echo 4;;
        '%') echo 4;;
        '^') echo 4;;
        '(') echo 5;;
    esac
}

getopassoc() {
    case "$1" in
        '^') echo r;;
        *)   echo l;;
    esac
}

showstacks() {
    [ -n "$1" ] && echo "Token: $1" || echo "End parsing"
    echo -e "\tOutput: `tr $'\n' ' ' <<< "$out"`"
    echo -e "\tOperators: `tr $'\n' ' ' <<< "$ops"`"
}

infix() {
    local out="" ops=""

    while [ "$#" -gt 0 ]; do
        grep -qE '^[0-9]+$' <<< "$1"
        if [ "$?" -eq 0 ]; then
            out="`sed -e '$a'"$1" -e '/^$/d' <<< "$out"`"

            showstacks "$1"
            shift && continue
        fi

        grep -q '^[-+*/^%]$' <<< "$1"
        if [ "$?" -eq 0 ]; then
            if [ -n "$ops" ]; then
                thispred=`getopprec "$1"`
                thisassoc=`getopassoc "$1"`
                topop="`sed -n '$p' <<< "$ops"`"
                thatpred=`getopprec "$topop"`
                thatassoc=`getopassoc "$topop"`
                while [ $thatpred -gt $thispred ] 2> /dev/null || ( [ \
                    $thatpred -eq $thispred ] 2> /dev/null && [ $thisassoc = \
                    'l' ] 2> /dev/null ); do # To /dev/null 'cus u r fake news

                    [ "$topop" = '(' ] && break

                    op="`sed -n '$p' <<< "$ops"`"
                    out="`sed -e '$a'"$op" -e '/^$/d' <<< "$out"`"
                    ops="`sed '$d' <<< "$ops"`"

                    topop="`sed -n '$p' <<< "$ops"`"
                    thatpred=`getopprec "$topop"`
                    thatassoc=`getopassoc "$topop"`
                done
            fi
            ops="`sed -e '$a'"$1" -e '/^$/d' <<< "$ops"`"

            showstacks "$1"
            shift && continue
        fi

        if [ "$1" = '(' ]; then
            ops="`sed -e '$a'"$1" -e '/^$/d' <<< "$ops"`"

            showstacks "$1"
            shift && continue
        fi

        if [ "$1" = ')' ]; then
            grep -q '^($' <<< "`sed -n '$p' <<< "$ops"`"
            while [ "$?" -ne 0 ]; do
                op="`sed -n '$p' <<< "$ops"`"
                out="`sed -e '$a'"$op" -e '/^$/d' <<< "$out"`"
                ops="`sed '$d' <<< "$ops"`"

                grep -q '^($' <<< "`sed '$p' <<< "$ops"`"
            done
            ops="`sed '$d' <<< "$ops"`"

            showstacks "$1"
            shift && continue
        fi

        shift
    done

    while [ -n "$ops" ]; do
        op="`sed -n '$p' <<< "$ops"`"
        out="`sed -e '$a'"$op" -e '/^$/d' <<< "$out"`"
        ops="`sed '$d' <<< "$ops"`"
    done

    showstacks "$1"
}

infix 3 + 4 \* 2 / \( 1 - 5 \) ^ 2 ^ 3


Option Explicit
Option Base 1

Function ShuntingYard(strInfix As String) As String
Dim i As Long, j As Long, token As String, tokenArray() As String
Dim stack() As Variant, queue() As Variant, discard As String
Dim op1 As String, op2 As String

Debug.Print strInfix

' Get tokens
tokenArray = Split(strInfix)

' Initialize array (removed later)
ReDim stack(1)
ReDim queue(1)

' Loop over tokens
Do While 1
    i = i + 1
    If i - 1 > UBound(tokenArray) Then
        Exit Do
    Else
        token = tokenArray(i - 1) 'i-1 due to Split returning a Base 0
    End If
    If token = "" Then: Exit Do

    ' Print
    Debug.Print i, token, Join(stack, ","), Join(queue, ",")
    ' If-loop over tokens (either brackets, operators, or numbers)
    If token = "(" Then
        stack = push(token, stack)
    ElseIf token = ")" Then
        While Peek(stack) <> "("
            queue = push(pop(stack), queue)
        Wend
        discard = pop(stack) 'discard "("
    ElseIf isOperator(token) Then
        op1 = token
        Do While (isOperator(Peek(stack)))
'            Debug.Print Peek(stack)
            op2 = Peek(stack)
            If op2 <> "^" And precedence(op1) = precedence(op2) Then
                '"^" is the only right-associative operator
                queue = push(pop(stack), queue)
            ElseIf precedence(op1$) < precedence(op2$) Then
                queue = push(pop(stack), queue)
            Else
                Exit Do
            End If
        Loop
        stack = push(op1, stack)
    Else   'number
        'actually, wrong operator could end up here, like say %
        'If the token is a number, then add it to the output queue.
        queue = push(CStr(token), queue)
    End If
Loop

While stack(1) <> ""
    If Peek(stack) = "(" Then Debug.Print "no matching ')'": End
    queue = push(pop(stack), queue)
Wend

' Print final output
ShuntingYard = Join(queue, " ")
Debug.Print "Output:"
Debug.Print ShuntingYard
End Function

'------------------------------------------
Function isOperator(op As String) As Boolean
    isOperator = InStr("+-*/^", op) <> 0 And Len(op$) = 1
End Function

Function precedence(op As String) As Integer
    If isOperator(op$) Then
        precedence = 1 _
            - (InStr("+-*/^", op$) <> 0) _
            - (InStr("*/^", op$) <> 0) _
            - (InStr("^", op$) <> 0)
    End If
End Function

'------------------------------------------
Function push(str, stack) As Variant
Dim out() As Variant, i As Long
If Not IsEmpty(stack(1)) Then
    out = stack
    ReDim Preserve out(1 To UBound(stack) + 1)
    out(UBound(out)) = str
Else
    ReDim out(1 To 1)
    out(1) = str
End If
push = out
End Function

Function pop(stack)
pop = stack(UBound(stack))
If UBound(stack) > 1 Then
    ReDim Preserve stack(1 To UBound(stack) - 1)
Else
    stack(1) = ""
End If
End Function

Function Peek(stack)
    Peek = stack(UBound(stack))
End Function


Module Module1
    Class SymbolType
        Public ReadOnly symbol As String
        Public ReadOnly precedence As Integer
        Public ReadOnly rightAssociative As Boolean

        Public Sub New(symbol As String, precedence As Integer, rightAssociative As Boolean)
            Me.symbol = symbol
            Me.precedence = precedence
            Me.rightAssociative = rightAssociative
        End Sub
    End Class

    ReadOnly Operators As Dictionary(Of String, SymbolType) = New Dictionary(Of String, SymbolType) From
    {
        {"^", New SymbolType("^", 4, True)},
        {"*", New SymbolType("*", 3, False)},
        {"/", New SymbolType("/", 3, False)},
        {"+", New SymbolType("+", 2, False)},
        {"-", New SymbolType("-", 2, False)}
    }

    Function ToPostfix(infix As String) As String
        Dim tokens = infix.Split(" ")
        Dim stack As New Stack(Of String)
        Dim output As New List(Of String)

        Dim Print = Sub(action As String) Console.WriteLine("{0,-4} {1,-18} {2}", action + ":", $"stack[ {String.Join(" ", stack.Reverse())} ]", $"out[ {String.Join(" ", output)} ]")

        For Each token In tokens
            Dim iv As Integer
            Dim op1 As SymbolType
            Dim op2 As SymbolType
            If Integer.TryParse(token, iv) Then
                output.Add(token)
                Print(token)
            ElseIf Operators.TryGetValue(token, op1) Then
                While stack.Count > 0 AndAlso Operators.TryGetValue(stack.Peek(), op2)
                    Dim c = op1.precedence.CompareTo(op2.precedence)
                    If c < 0 OrElse Not op1.rightAssociative AndAlso c <= 0 Then
                        output.Add(stack.Pop())
                    Else
                        Exit While
                    End If
                End While
                stack.Push(token)
                Print(token)
            ElseIf token = "(" Then
                stack.Push(token)
                Print(token)
            ElseIf token = ")" Then
                Dim top = ""
                While stack.Count > 0
                    top = stack.Pop()
                    If top <> "(" Then
                        output.Add(top)
                    Else
                        Exit While
                    End If
                End While
                If top <> "(" Then
                    Throw New ArgumentException("No matching left parenthesis.")
                End If
                Print(token)
            End If
        Next
        While stack.Count > 0
            Dim top = stack.Pop()
            If Not Operators.ContainsKey(top) Then
                Throw New ArgumentException("No matching right parenthesis.")
            End If
            output.Add(top)
        End While
        Print("pop")
        Return String.Join(" ", output)
    End Function

    Sub Main()
        Dim infix = "3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3"
        Console.WriteLine(ToPostfix(infix))
    End Sub

End Module


F partial(f, g)
   F fg(x)
      R @f(@g, x)
   R fg

F main()
   F ffs(f, x)
      R x.map(a -> @f(a))
   F f1(a) {R a * 2}
   F f2(a) {R a * a}

   V fsf1 = partial(ffs, f1)
   V fsf2 = partial(ffs, f2)

   print(fsf1([1, 2, 3, 4]))
   print(fsf2([1, 2, 3, 4]))

main()


import "/seq" for Stack
import "/pattern" for Pattern

/* To find out the precedence, we take the index of the
   token in the OPS string and divide by 2 (rounding down).
   This will give us: 0, 0, 1, 1, 2 */
var ops = "-+/*^"

var infixToPostfix = Fn.new { |infix|
    var sb = ""
    var s = Stack.new()
    var p = Pattern.new("+1/s")
    for (token in p.splitAll(infix)) {
        var c = token[0]
        var idx = ops.indexOf(c)

        // check for operator
        if (idx != - 1) {
            if (s.isEmpty) {
                s.push(idx)
            } else {
                while (!s.isEmpty) {
                    var prec2 = (s.peek()/2).floor
                    var prec1 = (idx/2).floor
                    if (prec2 > prec1 || (prec2 == prec1 && c != "^")) {
                        sb = sb + ops[s.pop()] + " "
                    } else break
                }
                s.push(idx)
            }
        } else if (c == "(") {
            s.push(-2)  // -2 stands for "("
        } else if (c == ")") {
            // until "(" on stack, pop operators.
            while (s.peek() != -2) sb = sb + ops[s.pop()] + " "
            s.pop()
        } else {
            sb = sb + token + " "
        }
    }
    while (!s.isEmpty) sb = sb + ops[s.pop()] + " "
    return sb
}

var es = [
    "3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3",
    "( ( 1 + 2 ) ^ ( 3 + 4 ) ) ^ ( 5 + 6 )"
]
for (e in es) {
    System.print("Infix   : %(e)")
    System.print("Postfix : %(infixToPostfix.call(e))\n")
}


with Ada.Text_IO;

procedure Partial_Function_Application is

   type Sequence is array(Positive range <>) of Integer;

   -- declare a function FS with a generic parameter F and a normal parameter S
   generic
      with function F(I: Integer) return Integer; -- generic parameter
   function FS (S: Sequence) return Sequence;

   -- define FS
   function FS (S: Sequence) return Sequence is
      Result: Sequence(S'First .. S'Last);
   begin
      for Idx in S'Range loop
         Result(Idx) := F(S(Idx));
      end loop;
      return Result;
   end FS;

   -- define functions F1 and F2
   function F1(I: Integer) return Integer is
   begin
      return 2*I;
   end F1;

   function F2(I: Integer) return Integer is
   begin
      return I**2;
   end F2;

   -- instantiate the function FS by F1 and F2 (partially apply F1 and F2 to FS)
   function FSF1 is new FS(F1);
   function FSF2 is new FS(F2);

   procedure Print(S: Sequence) is
   begin
      for Idx in S'Range loop
         Ada.Text_IO.Put(Integer'Image(S(Idx)));
      end loop;
      Ada.Text_IO.New_Line;
   end Print;

begin
   Print(FSF1((0,1,2,3)));
   Print(FSF2((0,1,2,3)));
   Print(FSF1((2,4,6,8)));
   Print(FSF2((2,4,6,8)));
end Partial_Function_Application;


MODE SET = FLEX[0]INT;

MODE F = PROC(INT)INT,
     FS = PROC(SET)SET;

PROC fs = (F f, SET set)SET: (
  [LWB set:UPB set]INT out;
  FOR i FROM LWB set TO UPB set DO out[i]:=f(set[i]) OD;
  out
);

PROC f1 = (INT value)INT: value * 2,
     f2 = (INT value)INT: value ** 2;

FS fsf1 = fs(f1,),
   fsf2 = fs(f2,);

[4]INT set;
FORMAT set fmt = $"("n(UPB set-LWB set)(g(0)", ")g(0)")"l$;

set := (0, 1, 2, 3);
  printf((set fmt, fsf1((0, 1, 2, 3)))); # prints (0, 2, 4, 6) #
  printf((set fmt, fsf2((0, 1, 2, 3)))); # prints (0, 1, 4, 9) #

set := (2, 4, 6, 8);
  printf((set fmt, fsf1((2, 4, 6, 8)))); # prints (4, 8, 12, 16) #
  printf((set fmt, fsf2((2, 4, 6, 8))))  # prints (4, 16, 36, 64) #


Function ShuntingYard(strInfix As String) As String

  Dim i as Integer
  Dim token, tokenArray() As String
  Dim stack(), queue() As Variant
  Dim discard As String
  Dim op1, op2 As String

  Dim Left_Brackets, Right_Brackets As Integer

  Dim output As String
  Dim dbl_output As Double

  Left_Brackets = CountFields(strInfix, "(")
  Right_Brackets = CountFields(strInfix, ")")

  If Left_Brackets = Right_Brackets Then

    'Get tokens
    tokenArray = Split(strInfix," ")

    'Initialize array (removed later)
    ReDim stack(1)
    ReDim queue(1)

    'Loop over tokens
    For i = 0 to tokenArray.Ubound

    'i = i + 1
      If i  > UBound(tokenArray) Then
        Exit For
      Else
        token = tokenArray(i ) 'i-1 due to Split returning a Base 0
      End If
      If token = "" Then
        Exit For
      End If

      Dim stackString As String
      Dim queuString As String

      for m as Integer = 0 to stack.Ubound
        stackString = stackString +  " " +  stack(m)
      Next

      for m as Integer = 0 to queue.Ubound
        queuString = queuString + " " +  queue(m)
      Next

      MsgBox(Str(i) + "      " + token + "      " + stackString + "      " + queuString)

      'Window1.txtQueu.Text = Window1.txtQueu.Text + Str(i) + "      " + token + "      " + stackString + "      " + queuString + EndOfLIne

      ' If-loop over tokens (either brackets, operators, or numbers)
      If token = "(" Then
        stack.Append(token)

      ElseIf token = ")" Then
        While stack(stack.Ubound) <> "("
          queue.Append(stack.pop)
        Wend

        discard = stack.Pop 'discard "("
      ElseIf isOperator(token) Then
        op1 = token

        //Do While (isOperator(Peek(stack)))
        While isOperator(    stack(stack.Ubound)  ) = True
          op2 = stack(stack.Ubound)
          If op2 <> "^" And precedence(op1) = precedence(op2) Then
            '"^" is the only right-associative operator

            queue.Append(stack.pop)

          ElseIf precedence(op1) < precedence(op2) Then
            queue.Append(stack.Pop)
          Else
            Exit While
          End If
        Wend
        //Loop

        stack.Append(op1)
      Else   'number
        'actually, wrong operator could end up here, like say %
        'If the token is a number, then add it to the output queue.
        queue.Append(CStr(token))
      End If

    Next

    for i = 0 to queue.Ubound
      output = output  +queue(i) + " "
    next

    for i = stack.Ubound DownTo 0
      output = output + stack(i)+" "
    next

    While InStr(output, "  ") <> 0
      output = ReplaceAll(output,"  "," ")
    Wend

    output = Trim(output)

    Return output

  Else

    MsgBox("Syntax Error!" + EndOfLine + "Count left brackets: " + Str(Left_Brackets) + EndOfLine +"Count right brackets: " + Str(Right_Brackets))

  End If

End Function

Function isOperator(op As String) As Boolean

  If InStr("+-*/^", op) <> 0 and Len(op) = 1 Then
    Return True
  End If

End Function

Function precedence(op As String) As Integer

  If isOperator(op) = True Then

    If op = "+" or op = "-"  Then
      Return 2
    ElseIf op = "/" or op = "*" Then
      Return 3
    ElseIf op = "^" Then
      Return 4
    End If

  End If

End Function


var input="3 + 4 * 2 / ( 1 - 5 ) ^ 2 ^ 3";

var opa=Dictionary("^",T(4,True),  "*",T(3,False),    // op:(prec,rAssoc)
	    "/",T(3,False), "+",T(2,False), "-",T(2,False),
);

"infix:  ".println(input);
"postfix:".println(parseInfix(input));

fcn parseInfix(e){
   stack:=List(); // holds operators and left parenthesis
   rpn:="";
   foreach tok in (e.split(" ")){
      switch(tok){
         case("("){ stack.append(tok) } // push "(" to stack
	 case(")"){
            while(True){ // pop item ("(" or operator) from stack
               op:=stack.pop();
	       if(op=="(") break;  // discard "("
	       rpn+=" " + op;      // add operator to result
	    }
	 }
         else{  // default
	    o1:=opa.find(tok);  // op or Void
	    if(o1){ // token is an operator
	       while(stack){
                  // consider top item on stack
		  op:=stack[-1]; o2:=opa.find(op);
		  if(not o2 or o1[0]>o2[0] or
                     (o1[0]==o2[0] and o1[1])) break;
		  // top item is an operator that needs to come off
		  stack.pop();
		  rpn+=" " + op;              // add it to result
	       }
	       // push operator (the new one) to stack
	       stack.append(tok);
	    }else // token is an operand
	       rpn+=(rpn and " " or "") + tok; // add operand to result
	 }
      } // switch
      display(tok,rpn,stack);
   } // foreach
   // drain stack to result
   rpn + stack.reverse().concat(" ");
}
fcn display(tok,rpn,stack){
   "Token|".println(tok);
   "Stack|".println(stack.concat());
   "Queue|".println(rpn);
   println();
}


-- PARTIAL APPLICATION --------------------------------------------

on f1(x)
    x * 2
end f1

on f2(x)
    x * x
end f2

on run

    tell curry(map)
        set fsf1 to |λ|(f1)
        set fsf2 to |λ|(f2)
    end tell

    {fsf1's |λ|({0, 1, 2, 3}), ¬
        fsf2's |λ|({0, 1, 2, 3}), ¬
        fsf1's |λ|({2, 4, 6, 8}), ¬
        fsf2's |λ|({2, 4, 6, 8})}
end run

-- GENERIC FUNCTIONS --------------------------------------------

-- curry :: (Script|Handler) -> Script
on curry(f)
    script
        on |λ|(a)
            script
                on |λ|(b)
                    |λ|(a, b) of mReturn(f)
                end |λ|
            end script
        end |λ|
    end script
end curry

-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map

-- Lift 2nd class handler function into 1st class script wrapper
-- mReturn :: Handler -> Script
on mReturn(f)
    if class of f is script then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn


      fsf1 = FNpartial(PROCfs(), FNf1())
      fsf2 = FNpartial(PROCfs(), FNf2())

      DIM seq(3)
      PRINT "Calling function fsf1 with sequence 1:"
      seq() = 0, 1, 2, 3 : PROC(fsf1)(seq())
      FOR i% = 0 TO 3 : PRINT seq(i%); : NEXT : PRINT
      PRINT "Calling function fsf1 with sequence 2:"
      seq() = 2, 4, 6, 8 : PROC(fsf1)(seq())
      FOR i% = 0 TO 3 : PRINT seq(i%); : NEXT : PRINT
      PRINT "Calling function fsf2 with sequence 1:"
      seq() = 0, 1, 2, 3 : PROC(fsf2)(seq())
      FOR i% = 0 TO 3 : PRINT seq(i%); : NEXT : PRINT
      PRINT "Calling function fsf2 with sequence 2:"
      seq() = 2, 4, 6, 8 : PROC(fsf2)(seq())
      FOR i% = 0 TO 3 : PRINT seq(i%); : NEXT : PRINT
      END

      REM Create a partial function:
      DEF FNpartial(RETURN f1%, RETURN f2%)
      LOCAL f$, p%
      DIM p% 7 : p%!0 = f1% : p%!4 = f2%
      f$ = "(s())" + CHR$&F2 + "(&" + STR$~p% + ")(" + \
      \              CHR$&A4 + "(&" + STR$~(p%+4) + ")(),s()):" + CHR$&E1
      DIM p% LEN(f$) + 4
      $(p%+4) = f$ : !p% = p%+4
      = p%

      REM Replaces the input sequence with the output sequence:
      DEF PROCfs(RETURN f%, seq())
      LOCAL i%
      FOR i% = 0 TO DIM(seq(),1)
        seq(i%) = FN(^f%)(seq(i%))
      NEXT
      ENDPROC

      DEF FNf1(n) = n * 2

      DEF FNf2(n) = n ^ 2


#include <stdio.h>
#include <unistd.h>
#include <stdlib.h>
#include <dlfcn.h>
#include <sys/wait.h>
#include <err.h>

typedef int (*intfunc)(int);
typedef void (*pfunc)(int*, int);

pfunc partial(intfunc fin)
{
	pfunc f;
	static int idx = 0;
	char cc[256], lib[256];
	FILE *fp;
	sprintf(lib, "/tmp/stuff%d.so", ++idx);
	sprintf(cc, "cc -pipe -x c -shared -o %s -", lib);

	fp = popen(cc, "w");
	fprintf(fp, "#define t typedef\xat int _i,*i;t _i(*__)(_i);__ p =(__)%p;"
		"void _(i _1, _i l){while(--l>-1)l[_1]=p(l[_1]);}", fin);
	fclose(fp);

	*(void **)(&f) = dlsym(dlopen(lib, RTLD_LAZY), "_");
	unlink(lib);
	return f;
}

int square(int a)
{
	return a * a;
}

int dbl(int a)
{
	return a + a;
}

int main()
{
	int x[] = { 1, 2, 3, 4 };
	int y[] = { 1, 2, 3, 4 };
	int i;

	pfunc f = partial(square);
	pfunc g = partial(dbl);

	printf("partial square:\n");
	f(x, 4);
	for (i = 0; i < 4; i++) printf("%d\n", x[i]);

	printf("partial double:\n");
	g(y, 4);
	for (i = 0; i < 4; i++) printf("%d\n", y[i]);

	return 0;
}


using System;
using System.Collections.Generic;
using System.Linq;

class PartialFunctionApplication
{
    static Func<T1, TResult> PartiallyApply<T1, T2, TResult>(Func<T1, T2, TResult> function, T2 argument2)
    {
        return argument1 => function(argument1, argument2);
    }

    static void Main()
    {
        var fs = (Func<IEnumerable<int>, Func<int, int>, IEnumerable<int>>)Enumerable.Select;
        var f1 = (Func<int, int>)(n => n * 2);
        var f2 = (Func<int, int>)(n => n * n);
        var fsf1 = PartiallyApply(fs, f1);
        var fsf2 = PartiallyApply(fs, f2);

        var s = new[] { 0, 1, 2, 3 };
        Console.WriteLine(string.Join(", ", fsf1(s)));
        Console.WriteLine(string.Join(", ", fsf2(s)));

        s = new[] { 2, 4, 6, 8 };
        Console.WriteLine(string.Join(", ", fsf1(s)));
        Console.WriteLine(string.Join(", ", fsf2(s)));
    }
}


#include <utility> // For declval.
#include <algorithm>
#include <array>
#include <iterator>
#include <iostream>

/* Partial application helper. */
template< class F, class Arg >
struct PApply
{
    F f;
    Arg arg;

    template< class F_, class Arg_ >
    PApply( F_&& f, Arg_&& arg )
        : f(std::forward<F_>(f)), arg(std::forward<Arg_>(arg))
    {
    }

    /*
     * The return type of F only gets deduced based on the number of arguments
     * supplied. PApply otherwise has no idea whether f takes 1 or 10 args.
     */
    template< class ... Args >
    auto operator() ( Args&& ...args )
        -> decltype( f(arg,std::declval<Args>()...) )
    {
        return f( arg, std::forward<Args>(args)... );
    }
};

template< class F, class Arg >
PApply<F,Arg> papply( F&& f, Arg&& arg )
{
    return PApply<F,Arg>( std::forward<F>(f), std::forward<Arg>(arg) );
}

/* Apply f to cont. */
template< class F >
std::array<int,4> fs( F&& f, std::array<int,4> cont )
{
    std::transform( std::begin(cont), std::end(cont), std::begin(cont),
                    std::forward<F>(f) );
    return cont;
}

std::ostream& operator << ( std::ostream& out, const std::array<int,4>& c )
{
    std::copy( std::begin(c), std::end(c),
               std::ostream_iterator<int>(out, ", ") );
    return out;
}

int f1( int x ) { return x * 2; }
int f2( int x ) { return x * x; }

int main()
{
    std::array<int,4> xs = {{ 0, 1, 2, 3 }};
    std::array<int,4> ys = {{ 2, 4, 6, 8 }};

    auto fsf1 = papply( fs<decltype(f1)>, f1 );
    auto fsf2 = papply( fs<decltype(f2)>, f2 );

    std::cout << "xs:\n"
              << "\tfsf1: " << fsf1(xs) << '\n'
              << "\tfsf2: " << fsf2(xs) << "\n\n"
              << "ys:\n"
              << "\tfsf1: " << fsf1(ys) << '\n'
              << "\tfsf2: " << fsf2(ys) << '\n';
}


shared void run() {

	function fs(Integer f(Integer n), {Integer*} s) => s.map(f);

	function f1(Integer n) => n * 2;
	function f2(Integer n) => n ^ 2;

	value fsCurried = curry(fs);
	value fsf1 = fsCurried(f1);
	value fsf2 = fsCurried(f2);

	value ints = 0..3;
	print("fsf1(``ints``) is ``fsf1(ints)`` and fsf2(``ints``) is ``fsf2(ints)``");

	value evens = (2..8).by(2);
	print("fsf1(``evens``) is ``fsf1(evens)`` and fsf2(``evens``) is ``fsf2(evens)``");
}


(defn fs [f s] (map f s))
(defn f1 [x] (* 2 x))
(defn f2 [x] (* x x))
(def fsf1 (partial fs f1))
(def fsf2 (partial fs f2))

(doseq [s [(range 4) (range 2 9 2)]]
  (println "seq: " s)
  (println "  fsf1: " (fsf1 s))
  (println "  fsf2: " (fsf2 s)))


partial = (f, g) ->
  (s) -> f(g, s)

fs = (f, s) -> (f(a) for a in s)
f1 = (a) -> a * 2
f2 = (a) -> a * a
fsf1 = partial(fs, f1)
fsf2 = partial(fs, f2)

do ->
  for seq in [[0..3], [2,4,6,8]]
    console.log fsf1 seq
    console.log fsf2 seq


(defun fs (f s)
  (mapcar f s))
(defun f1 (i)
  (* i 2))
(defun f2 (i)
  (expt i 2))

(defun partial (func &rest args1)
  (lambda (&rest args2)
    (apply func (append args1 args2))))

(setf (symbol-function 'fsf1) (partial #'fs #'f1))
(setf (symbol-function 'fsf2) (partial #'fs #'f2))

(dolist (seq '((0 1 2 3) (2 4 6 8)))
  (format t
          "~%seq: ~A~%  fsf1 seq: ~A~%  fsf2 seq: ~A"
	  seq
          (fsf1 seq)
          (fsf2 seq)))


import std.stdio, std.algorithm, std.traits;

auto fs(alias f)(in int[] s) pure nothrow
if (isCallable!f && ParameterTypeTuple!f.length == 1) {
    return s.map!f;
}

int f1(in int x) pure nothrow { return x * 2; }
int f2(in int x) pure nothrow { return x ^^ 2; }

alias fsf1 = fs!f1;
alias fsf2 = fs!f2;

void main() {
    foreach (const d; [[0, 1, 2, 3], [2, 4, 6, 8]]) {
        d.fsf1.writeln;
        d.fsf2.writeln;
    }
}


def pa(f, args1) {
  return def partial {
    match [`run`, args2] {
      E.call(f, "run", args1 + args2)
    }
  }
}

def fs(f, s) {
  var r := []
  for n in s {
    r with= f(n)
  }
  return r
}

def f1(n) { return n * 2 }
def f2(n) { return n ** 2 }

def fsf1 := pa(fs, [f1])
def fsf2 := pa(fs, [f2])
for s in [0..3, [2, 4, 6, 8]] {
  for f in [fsf1, fsf2] {
    println(f(s))
  }
}


import system'collections;
import system'routines;
import extensions;

public program()
{
    var partial := (afs,af => (s => afs(af, s)));

    var fs := (f,s => s.selectBy:(x => f(x)).summarize(new ArrayList()).toArray());
    var f1 := (x => x * 2);
    var f2 := (x => x * x);

    var fsf1 := partial(fs, f1);
    var fsf2 := partial(fs, f2);

    console.printLine(fsf1(new int[]{2,4,6,8}).toString());
    console.printLine(fsf2(new int[]{2,4,6,8}).toString())
}


let fs f s = List.map f s
let f1 n = n * 2
let f2 n = n * n

let fsf1 = fs f1
let fsf2 = fs f2

printfn "%A" (fsf1 [0; 1; 2; 3])
printfn "%A" (fsf1 [2; 4; 6; 8])
printfn "%A" (fsf2 [0; 1; 2; 3])
printfn "%A" (fsf2 [2; 4; 6; 8])


USING: kernel math prettyprint sequences ;
IN: rosetta-code.partial-function-application

ALIAS: fs map
: f1   ( n -- m  ) 2 * ;
: f2   ( n -- m  ) dup * ;
: fsf1 ( s -- s' ) [ f1 ] fs ;
: fsf2 ( s -- s' ) [ f2 ] fs ;

{ 0 1 2 3 } [ fsf1 . ] [ fsf2 . ] bi
{ 2 4 6 8 } [ fsf1 . ] [ fsf2 . ] bi


fs = map
f1 = (* 2)
f2 = (^ 2)

fsf1 = fs.curry( f1 )
fsf2 = fs.curry( f2 )

println( fsf1(0..3) )
println( fsf2(0..3) )
println( fsf1(2..8 by 2) )
println( fsf2(2..8 by 2) )


package main

import "fmt"

// Using a method bound to a function type:

// fn is a simple function taking an integer and returning another.
type fn func(int) int

// fs applies fn to each argument returning all results.
func (f fn) fs(s ...int) (r []int) {
	for _, i := range s {
		r = append(r, f(i))
	}
	return r
}

// Two simple functions for demonstration.
func f1(i int) int { return i * 2 }
func f2(i int) int { return i * i }

// Another way:

// addn returns a function that adds n to a sequence of numbers
func addn(n int) func(...int) []int {
	return func(s ...int) []int {
		var r []int
		for _, i := range s {
			r = append(r, n+i)
		}
		return r
	}
}

func main() {
	// Turning a method into a function bound to it's reciever:
	fsf1 := fn(f1).fs
	fsf2 := fn(f2).fs
	// Or using a function that returns a function:
	fsf3 := addn(100)

	s := []int{0, 1, 2, 3}
	fmt.Println("For s =", s)
	fmt.Println("  fsf1:", fsf1(s...))       // Called with a slice
	fmt.Println("  fsf2:", fsf2(0, 1, 2, 3)) // ... or with individual arguments
	fmt.Println("  fsf3:", fsf3(0, 1, 2, 3))
	fmt.Println("  fsf2(fsf1):", fsf2(fsf1(s...)...))

	s = []int{2, 4, 6, 8}
	fmt.Println("For s =", s)
	fmt.Println("  fsf1:", fsf1(2, 4, 6, 8))
	fmt.Println("  fsf2:", fsf2(s...))
	fmt.Println("  fsf3:", fsf3(s...))
	fmt.Println("  fsf3(fsf1):", fsf3(fsf1(s...)...))
}


def fs = { fn, values -> values.collect { fn(it) } }
def f1 = { v -> v * 2 }
def f2 = { v -> v ** 2 }
def fsf1 = fs.curry(f1)
def fsf2 = fs.curry(f2)


link printf

procedure main()
   fsf1 := partial(fs,f1)
   fsf2 := partial(fs,f2)
   every s :=  [ 0, 1, 2, 3 ] |
               [ 2, 4, 6, 8 ] do {
         printf("\ns       := %s\n",list2string(s))
         printf("fsf1(s) := %s\n",list2string(fsf1(s)))
         printf("fsf2(s) := %s\n",list2string(fsf2(s)))
      }
end

procedure partial(f,g)  #: partial application of f & g
   @( p := create repeat {
                  s := (r@&source)[1]  # return r / get argument s
                  r := f(g,s)          # apply f(g,...)
                  }
      )                                # create and activate procedure p
   return p
end

procedure fs(f,s)       #: return list where f is applied to each element of s
   every put(r := [], f(!s))
   return r
end

procedure f1(n)         # double
   return n * 2
end

procedure f2(n)         #: square
   return n ^ 2
end

procedure list2string(L)         #: format list as a string
   every (s := "[ ") ||:= !L || " "
   return s || "]"
end


import java.util.Arrays;

public class PartialApplication {
	interface IntegerFunction {
		int call(int arg);
	}

	// Original method fs(f, s).
	static int[] fs(IntegerFunction f, int[] s) {
		int[] r = new int[s.length];
		for (int i = 0; i < s.length; i++)
			r[i] = f.call(s[i]);
		return r;
	}

	interface SequenceFunction {
		int[] call(int[] arg);
	}

	// Curried method fs(f).call(s),
	// necessary for partial application.
	static SequenceFunction fs(final IntegerFunction f) {
		return new SequenceFunction() {
			public int[] call(int[] s) {
				// Call original method.
				return fs(f, s);
			}
		};
	}

	static IntegerFunction f1 = new IntegerFunction() {
		public int call(int i) {
			return i * 2;
		}
	};

	static IntegerFunction f2 = new IntegerFunction() {
		public int call(int i) {
			return i * i;
		}
	};

	static SequenceFunction fsf1 = fs(f1); // Partial application.

	static SequenceFunction fsf2 = fs(f2);

	public static void main(String[] args) {
		int[][] sequences = {
			{ 0, 1, 2, 3 },
			{ 2, 4, 6, 8 },
		};

		for (int[] array : sequences) {
			System.out.printf(
			    "array: %s\n" +
			    "  fsf1(array): %s\n" +
			    "  fsf2(array): %s\n",
			    Arrays.toString(array),
			    Arrays.toString(fsf1.call(array)),
			    Arrays.toString(fsf2.call(array)));
		}
	}
}


var f1 = function (x) { return x * 2; },
    f2 = function (x) { return x * x; },

    fs = function (f, s) {
        return function (s) {
            return s.map(f);
        }
    },

    fsf1 = fs(f1),
    fsf2 = fs(f2);

// Test
    [
        fsf1([0, 1, 2, 3]),
        fsf2([0, 1, 2, 3]),

        fsf1([2, 4, 6, 8]),
        fsf2([2, 4, 6, 8])
    ]


# fs(f, s) takes a function, f, of one value and a sequence of values s,
# and returns an ordered sequence of the result of applying function f to every value of s in turn.

def fs(f; s): s | f;

# f1 takes a value and returns it multiplied by 2:
def f1: 2 * .;

# f2 takes a value and returns it squared:
def f2: . * .;

# Partially apply f1 to fs to form function fsf1(s):
def fsf1(s): fs(f1;s);

# Partially apply f2 to fs to form function fsf2(s)
def fsf2(s): fs(f2; s);

# Test fsf1 and fsf2 by evaluating them with s being the sequence of integers from 0 to 3 inclusive ...

"fsf1",
[fsf1(range(0;4))],
"fsf2",
[fsf2(range(0;4))],

# and then the sequence of even integers from 2 to 8 inclusive:

"fsf1",
[fsf1(range(2;9;2))],
"fsf2",
[fsf2(range(2;9;2))]


fs(f, s) = map(f, s)
f1(x) = 2x
f2(x) = x^2
fsf1(s) = fs(f1, s)
fsf2(s) = fs(f2, s)

s1 = [0, 1, 2 ,3]
s2 = [2, 4, 6, 8]
println("fsf1 of s1 is $(fsf1(s1))")
println("fsf2 of s1 is $(fsf2(s1))")
println("fsf1 of s2 is $(fsf1(s2))")
println("fsf2 of s2 is $(fsf2(s2))")


// version 1.1.2

typealias Func  = (Int) -> Int
typealias FuncS = (Func, List<Int>) -> List<Int>

fun fs(f: Func, seq: List<Int>) = seq.map { f(it) }

fun partial(fs: FuncS, f: Func) = { seq: List<Int> -> fs(f, seq) }

fun f1(n: Int) = 2 * n

fun f2(n: Int) = n * n

fun main(args: Array<String>) {
    val fsf1 = partial(::fs, ::f1)
    val fsf2 = partial(::fs, ::f2)
    val seqs = listOf(
        listOf(0, 1, 2, 3),
        listOf(2, 4, 6, 8)
    )
    for (seq in seqs) {
        println(fs(::f1, seq))      // normal
        println(fsf1(seq))          // partial
        println(fs(::f2, seq))      // normal
        println(fsf2(seq))          // partial
        println()
    }
}


(defun partial
  "The partial function is arity 2 where the first parameter must be a
  function and the second parameter may either be a single item or a list of
  items.

  When funcall is called against the result of the partial call, a second
  parameter is applied to the partial function. This parameter too may be
  either a single item or a list of items."
  ((func args-1) (when (is_list args-1))
    (match-lambda
      ((args-2) (when (is_list args-2))
        (apply func (++ args-1 args-2)))
      ((arg-2)
        (apply func (++ args-1 `(,arg-2))))))
  ((func arg-1)
    (match-lambda
      ((args-2) (when (is_list args-2))
        (apply func (++ `(,arg-1) args-2)))
      ((arg-2)
        (funcall func arg-1 arg-2)))))


:- object(partial_functions).

    :- public(show/0).

    show :-
        % create the partial functions
        create_partial_function(f1, PF1),
        create_partial_function(f2, PF2),
        % apply the partial functions
        Sequence1 = [0,1,2,3],
        call(PF1, Sequence1, PF1Sequence1), output_results(PF1, Sequence1, PF1Sequence1),
        call(PF2, Sequence1, PF2Sequence1), output_results(PF2, Sequence1, PF2Sequence1),
        Sequence2 = [2,4,6,8],
        call(PF1, Sequence2, PF1Sequence2), output_results(PF1, Sequence2, PF1Sequence2),
        call(PF2, Sequence2, PF2Sequence2), output_results(PF2, Sequence2, PF2Sequence2).

    create_partial_function(Closure, fs(Closure)).

    output_results(Function, Input, Output) :-
        write(Input), write(' -> '), write(Function), write(' -> '), write(Output), nl.

    fs(Closure, Arg1, Arg2) :-
        meta::map(Closure, Arg1, Arg2).

    f1(Value, Double) :-
        Double is 2*Value.

    f2(Value, Square) :-
        Square is Value*Value.

:- end_object.


function map(f, ...)
    local t = {}
    for k, v in ipairs(...) do
        t[#t+1] = f(v)
    end
    return t
end

function timestwo(n)
    return n * 2
end

function squared(n)
    return n ^ 2
end

function partial(f, arg)
    return function(...)
        return f(arg, ...)
    end
end

timestwo_s = partial(map, timestwo)
squared_s = partial(map, squared)

print(table.concat(timestwo_s{0, 1, 2, 3}, ', '))
print(table.concat(squared_s{0, 1, 2, 3}, ', '))
print(table.concat(timestwo_s{2, 4, 6, 8}, ', '))
print(table.concat(squared_s{2, 4, 6, 8}, ', '))


:- module partial_function_application.
:- interface.

:- import_module io.

:- pred main(io::di, io::uo) is det.

:- implementation.
:- import_module int, list.

main(!IO) :-
    io.write((fsf1)([0, 1, 2, 3]), !IO), io.nl(!IO),
    io.write((fsf2)([0, 1, 2, 3]), !IO), io.nl(!IO),
    io.write((fsf1)([2, 4, 6, 8]), !IO), io.nl(!IO),
    io.write((fsf2)([2, 4, 6, 8]), !IO), io.nl(!IO).

:- func fs(func(V) = V, list(V)) = list(V).

fs(_, []) = [].
fs(F, [V | Vs]) = [F(V) | fs(F, Vs)].

:- func f1(int) = int.

f1(V) = V * 2.

:- func f2(int) = int.

f2(V) = V * V.

:- func fsf1 = (func(list(int)) = list(int)).

fsf1 = fs(f1).

:- func fsf2 = (func(list(int)) = list(int)).

fsf2 = fs(f2).


'map :fs
(dup +) :f1
(dup *) :f2
('f1 fs) :fsf1
('f2 fs) :fsf2

(0 1 2 3) fsf1 puts!
(0 1 2 3) fsf2 puts!
(2 4 6 8) fsf1 puts!
(2 4 6 8) fsf2 puts!


using System;
using System.Console;

module Partial
{
    fs[T] (f : T -> T, s : list[T]) : list[T]
    {
        $[f(x)| x in s]
    }

    f1 (x : int) : int
    {
        x * 2
    }

    f2 (x : int) : int
    {
        x * x
    }

    curry[T, U, V] (f : T * U -> V, x : T) : U -> V
    {
        f(x, _)
    }

    // curryr() isn't actually used in this task, I just include it for symmetry
    curryr[T, U, V] (f : T * U -> V, x : U) : T -> V
    {
        f(_, x)
    }

    Main() : void
    {
        def fsf1 = curry(fs, f1);
        def fsf2 = curry(fs, f2);
        def test1 = $[0 .. 3];
        def test2 = $[x | x in [2 .. 8], x % 2 == 0];

        WriteLine (fsf1(test1));
        WriteLine (fsf1(test2));
        WriteLine (fsf2(test1));
        WriteLine (fsf2(test2));

    }
}


import sequtils

type

  Func = proc(n: int): int
  FuncS = proc(f: Func; s: seq[int]): seq[int]

proc fs(f: Func; s: seq[int]): seq[int] = s.map(f)

proc partial(fs: FuncS; f: Func): auto =
  result = proc(s: seq[int]): seq[int] = fs(f, s)

proc f1(n: int): int = 2 * n
proc f2(n: int): int = n * n

when isMainModule:

  const Seqs = @[@[0, 1, 2, 3], @[2, 4, 6, 8]]

  let fsf1 = partial(fs, f1)
  let fsf2 = partial(fs, f2)

  for s in Seqs:
    echo fs(f1, s)    # Normal.
    echo fsf1(s)      # Partial.
    echo fs(f2, s)    # Normal.
    echo fsf2(s)      # Partial.
    echo ""


#
let fs f s = List.map f s
let f1 value = value * 2
let f2 value = value * value

let fsf1 = fs f1
let fsf2 = fs f2
;;
val fs : ('a -> 'b) -> 'a list -> 'b list = <fun>
val f1 : int -> int = <fun>
val f2 : int -> int = <fun>
val fsf1 : int list -> int list = <fun>
val fsf2 : int list -> int list = <fun>

# fsf1 [0; 1; 2; 3];;
- : int list = [0; 2; 4; 6]
# fsf2 [0; 1; 2; 3];;
- : int list = [0; 1; 4; 9]
# fsf1 [2; 4; 6; 8];;
- : int list = [4; 8; 12; 16]
# fsf2 [2; 4; 6; 8];;
- : int list = [4; 16; 36; 64]


: fs(s, f)     f s map ;
: f1           2 * ;
: f2           sq  ;

#f1 #fs curry => fsf1
#f2 #fs curry => fsf2


#include <order/interpreter.h>

#define ORDER_PP_DEF_8fs ORDER_PP_FN( 8fn(8F, 8S, 8seq_map(8F, 8S)) )

#define ORDER_PP_DEF_8f1 ORDER_PP_FN( 8fn(8V, 8times(8V, 2)) )

#define ORDER_PP_DEF_8f2 ORDER_PP_FN( 8fn(8V, 8times(8V, 8V)) )

ORDER_PP(
  8let((8F, 8fs(8f1))
       (8G, 8fs(8f2)),
       8do(
         8print(8ap(8F, 8seq(0, 1, 2, 3)) 8comma 8space),
         8print(8ap(8G, 8seq(0, 1, 2, 3)) 8comma 8space),
         8print(8ap(8F, 8seq(2, 4, 6, 8)) 8comma 8space),
         8print(8ap(8G, 8seq(2, 4, 6, 8))))) )


sub fs(&) {
        my $func = shift;
        sub { map $func->($_), @_ }
}

sub double($) { shift() * 2 }
sub square($) { shift() ** 2 }

my $fs_double = fs(\&double);
my $fs_square = fs(\&square);

my @s = 0 .. 3;
print "fs_double(@s): @{[ $fs_double->(@s) ]}\n";
print "fs_square(@s): @{[ $fs_square->(@s) ]}\n";

@s = (2, 4, 6, 8);
print "fs_double(@s): @{[ $fs_double->(@s) ]}\n";
print "fs_square(@s): @{[ $fs_square->(@s) ]}\n";


with javascript_semantics
function fs(integer rid, sequence s)
    sequence r = repeat(0,length(s))
    for i=1 to length(s) do
        r[i] = rid(s[i])
    end for
    return r
end function

function p_apply(sequence f, args)
    integer {f1,f2} = f
    return f1(f2,args)
end function

function f1(integer i)
    return i+i
end function

function f2(integer i)
    return i*i
end function

printf(1,"%v\n",{p_apply({fs,f1},{0,1,2,3})})
printf(1,"%v\n",{p_apply({fs,f2},{0,1,2,3})})


(def 'fs mapcar)
(de f1 (N) (* 2 N))
(de f2 (N) (* N N))

(de partial (F1 F2)
   (curry (F1 F2) @
      (pass F1 F2) ) )

(def 'fsf1 (partial fs f1))
(def 'fsf2 (partial fs f2))

(for S '((0 1 2 3) (2 4 6 8))
   (println (fsf1 S))
   (println (fsf2 S)) )


from functools import partial

def fs(f, s): return [f(value) for value in s]

def f1(value): return value * 2

def f2(value): return value ** 2

fsf1 = partial(fs, f1)
fsf2 = partial(fs, f2)

s = [0, 1, 2, 3]
assert fs(f1, s) == fsf1(s) # ==  [0, 2, 4, 6]
assert fs(f2, s) == fsf2(s) # ==  [0, 1, 4, 9]

s = [2, 4, 6, 8]
assert fs(f1, s) == fsf1(s) # ==  [4, 8, 12, 16]
assert fs(f2, s) == fsf2(s) # ==  [4, 16, 36, 64]


  [ [] unrot
    swap nested
    ' join nested
    join nested
    ' witheach nested
    swap join
    do ]                  is fs   ( f s --> [ )

 [ 2 * ]                  is f1   (   n --> n )

 [ 2 ** ]                 is f2   (   n --> n )

 [ ' f1 swap fs ]         is fsf1 (   s --> [ )

 [ ' f2 swap fs ]         is fsf2 (   s --> [ )

 ' [ 0 1 2 3 ] fsf1 echo cr
 ' [ 0 1 2 3 ] fsf2 echo cr
 ' [ 2 4 6 8 ] fsf1 echo cr
 ' [ 2 4 6 8 ] fsf2 echo cr

( ... or, using Quackery's partial applicator "witheach",
      which applies the word or nest following it to each
      item in a nest on the top of the stack ...          )

cr

' [ [ 0 1 2 3 ] [ 2 4 6 8 ] ]
  witheach
    [ dup ' [ fsf1 fsf2 ]
      witheach [ do echo cr ] ]


partially.apply <- function(f, ...) {
  capture <- list(...)
  function(...) {
    do.call(f, c(capture, list(...)))
  }
}

fs <- function(f, ...) sapply(list(...), f)
f1 <- function(x) 2*x
f2 <- function(x) x^2

fsf1 <- partially.apply(fs, f1)
fsf2 <- partially.apply(fs, f2)

fsf1(0:3)
fsf2(0:3)
fsf1(seq(2,8,2))
fsf2(seq(2,8,2))


#lang racket

(define (fs f s) (map f s))
(define (f1 n) (* n 2))
(define (f2 n) (* n n))

(define fsf1 (curry fs f1))
(define fsf2 (curry fs f2))

(fsf1 '(0 1 2 3))
(fsf1 '(2 4 6 8))
(fsf2 '(0 1 2 3))
(fsf2 '(2 4 6 8))


/*REXX program demonstrates a method of a  partial function application.      */
s=;      do a=0  to 3                  /*build 1st series of some low integers*/
         s=strip(s a)                  /*append to the integer to the  S  list*/
         end   /*a*/

call fs 'f1',s;         say 'for f1:  series=' s",   result="  result
call fs 'f2',s;         say 'for f2:  series=' s",   result="  result

s=;      do b=2  to  8  by 2           /*build 2nd series, low even integers. */
         s=strip(s b)                  /*append to the integer to the  S  list*/
         end   /*b*/

call fs 'f1',s;         say 'for f1:  series=' s",   result="  result
call fs 'f2',s;         say 'for f2:  series=' s",   result="  result
exit                                   /*stick a fork in it,  we're all done. */
/*────────────────────────────────────────────────────────────────────────────*/
f1:  return arg(1)* 2
f2:  return arg(1)**2
/*────────────────────────────────────────────────────────────────────────────*/
fs:  procedure;   arg f,s;   $=;       do j=1  for words(s);   z=word(s,j)
                                       interpret '$=$'     f"("z')'
                                       end  /*j*/
     return strip($)


fs = proc { |f, s| s.map &f }
f1 = proc { |n| n * 2 }
f2 = proc { |n| n ** 2 }
fsf1 = fs.curry[f1]
fsf2 = fs.curry[f2]

[0..3, (2..8).step(2)].each do |e|
  p fsf1[e]
  p fsf2[e]
end


def fs[X](f:X=>X)(s:Seq[X]) = s map f
def f1(x:Int) = x * 2
def f2(x:Int) = x * x

def fsf[X](f:X=>X) = fs(f) _
val fsf1 = fsf(f1) // or without the fsf intermediary: val fsf1 = fs(f1) _
val fsf2 = fsf(f2) // or without the fsf intermediary: val fsf2 = fs(f2) _

assert(fsf1(List(0,1,2,3)) == List(0,2,4,6))
assert(fsf2(List(0,1,2,3)) == List(0,1,4,9))


func fs(f) {
    func(*args) {
        args.map {f(_)}
    }
}

func double(n) { n  * 2 };
func square(n) { n ** 2 };

var fs_double = fs(double);
var fs_square = fs(square);

var s = (0 .. 3);
say "fs_double(#{s}): #{fs_double(s...)}";
say "fs_square(#{s}): #{fs_square(s...)}";

s = [2, 4, 6, 8];
say "fs_double(#{s}): #{fs_double(s...)}";
say "fs_square(#{s}): #{fs_square(s...)}";


| f1 f2 fs fsf1 fsf2 partial |

partial := [ :afs :af | [ :s | afs value: af value: s ] ].

fs := [ :f :s | s collect: [ :x | f value: x ]].
f1 := [ :x | x * 2 ].
f2:= [ :x | x * x ].
fsf1 := partial value: fs value: f1.
fsf2 := partial value: fs value: f2.

fsf1 value: (0 to: 3).
" #(0 2 4 6)"
fsf2 value: (0 to: 3).
" #(0 1 4 9)"

fsf1 value: #(2 4 6 8).
" #(4 8 12 16)"
fsf2 value: #(2 4 6 8).
" #(4 16 36 64)"


package require Tcl 8.6
proc partial {f1 f2} {
    variable ctr
    coroutine __curry[incr ctr] apply {{f1 f2} {
	for {set x [info coroutine]} 1 {} {
	    set x [{*}$f1 $f2 [yield $x]]
	}
    }} $f1 $f2
}


Module PartialApplication
    Function fs(Of TSource, TResult)(f As Func(Of TSource, TResult), s As IEnumerable(Of TSource)) As IEnumerable(Of TResult)
        ' This is exactly what Enumerable.Select does.
        Return s.Select(f)
    End Function

    Function f1(x As Integer) As Integer
        Return x * 2
    End Function

    Function f2(x As Integer) As Integer
        Return x * x
    End Function

    ' The overload that takes a binary function and partially applies to its first parameter.
    Function PartialApply(Of T1, T2, TResult)(f As Func(Of T1, T2, TResult), arg As T1) As Func(Of T2, TResult)
        Return Function(arg2) f(arg, arg2)
    End Function

    Sub Main()
        Dim args1 As Integer() = {0, 1, 2, 3}
        Dim args2 As Integer() = {2, 4, 6, 8}

        Dim fsf1 = PartialApply(Of Func(Of Integer, Integer), IEnumerable(Of Integer), IEnumerable(Of Integer))(AddressOf fs, AddressOf f1)
        Dim fsf2 = PartialApply(Of Func(Of Integer, Integer), IEnumerable(Of Integer), IEnumerable(Of Integer))(AddressOf fs, AddressOf f2)

        Console.WriteLine("fsf1, 0-3: " & String.Join(", ", fsf1(args1)))
        Console.WriteLine("fsf1, evens: " & String.Join(", ", fsf1(args2)))
        Console.WriteLine("fsf2, 0-3: " & String.Join(", ", fsf2(args1)))
        Console.WriteLine("fsf2, evens: " & String.Join(", ", fsf2(args2)))
    End Sub
End Module


var fs = Fn.new { |f, s| s.map { |e| f.call(e) }.toList }
var f1 = Fn.new { |n| 2 * n }
var f2 = Fn.new { |n| n * n }

var partial = Fn.new { |f, g| Fn.new { |x| f.call(g, x) } }

var ss = [[0, 1, 2, 3], [2, 4, 6, 8]]
for (s in ss) {
    var fsf1 = partial.call(fs, f1)
    var fsf2 = partial.call(fs, f2)
    System.print(fsf1.call(s))
    System.print(fsf2.call(s))
    System.print()
}


F pascal(n)
   V row = [1]
   V k = [0]
   L 0 .< max(n, 0)
      print(row.join(‘ ’).center(16))
      row = zip(row [+] k, k [+] row).map((l, r) -> l + r)

pascal(7)


*        Pascal's triangle         25/10/2015
PASCAL   CSECT
         USING  PASCAL,R15         set base register
         LA     R7,1               n=1
LOOPN    C      R7,=A(M)           do n=1 to m
         BH     ELOOPN             if n>m then goto
         MVC    U,=F'1'            u(1)=1
         LA     R8,PG              [email protected]
         LA     R6,1               i=1
LOOPI    CR     R6,R7              do i=1 to n
         BH     ELOOPI             if i>n then goto
         LR     R1,R6              i
         SLA    R1,2               i*4
         L      R3,T-4(R1)         t(i)
         L      R4,T(R1)           t(i+1)
         AR     R3,R4              t(i)+t(i+1)
         ST     R3,U(R1)           u(i+1)=t(i)+t(i+1)
         LR     R1,R6              i
         SLA    R1,2               i*4
         L      R2,U-4(R1)         u(i)
         XDECO  R2,XD              edit u(i)
         MVC    0(4,R8),XD+8       output u(i):4
         LA     R8,4(R8)           pgi=pgi+4
         LA     R6,1(R6)           i=i+1
         B      LOOPI              end i
ELOOPI   MVC    T((M+1)*(L'T)),U   t=u
         XPRNT  PG,80              print
         LA     R7,1(R7)           n=n+1
         B      LOOPN              end n
ELOOPN   XR     R15,R15            set return code
         BR     R14                return to caller
M        EQU    11                 <== input
T        DC     (M+1)F'0'          t(m+1) init 0
U        DC     (M+1)F'0'          u(m+1) init 0
PG       DC     CL80' '            pg     init ' '
XD       DS     CL12               temp
         YREGS
         END    PASCAL


\ print the array
: .arr \ a -- a
  ( . space ) a:each ;

: pasc \ a --
  \ print the row
  .arr cr
  dup
  \ create two rows from the first, one with a leading the other with a trailing 0
  [0] 0 a:insert swap 0 a:push
  \ add the arrays together to make the new one
  ' n:+ a:op ;

\ print the first 16 rows:
[1] ' pasc 16 times


PROC Main()
  BYTE count=[10],row,item
  CHAR ARRAY s(5)
  INT v

  FOR row=0 TO count-1
  DO
    v=1
    FOR item=0 TO row
    DO
      StrI(v,s)
      Position(2*(count-row)+4*item-s(0),row+1)
      Print(s)
      v=v*(row-item)/(item+1)
    OD
    PutE()
  OD
RETURN


package Pascal is

   type Row is array (Natural range <>) of Natural;

   function Length(R: Row) return Positive;

   function First_Row(Max_Length: Positive) return Row;

   function Next_Row(R: Row) return Row;

end Pascal;


PRIO MINLWB = 8, MAXUPB = 8;
OP MINLWB = ([]INT a,b)INT: (LWB a<LWB b|LWB a|LWB b),
   MAXUPB = ([]INT a,b)INT: (UPB a>UPB b|UPB a|UPB b);

OP + = ([]INT a,b)[]INT:(
  [a MINLWB b:a MAXUPB b]INT out; FOR i FROM LWB out TO UPB out DO out[i]:= 0 OD;
  out[LWB a:UPB a] := a; FOR i FROM LWB b TO UPB b DO out[i]+:= b[i] OD;
  out
);

INT width = 4, stop = 9;
FORMAT centre = $n((stop-UPB row+1)*width OVER 2)(q)$;

FLEX[1]INT row := 1; # example of rowing #
FOR i WHILE
  printf((centre, $g(-width)$, row, $l$));
# WHILE # i < stop DO
  row := row[AT 1] + row[AT 2]
OD


begin
    % prints the first n lines of Pascal's triangle lines %
    % if n is <= 0, no output is produced                 %
    procedure printPascalTriangle( integer value n ) ;
        if n > 0 then begin
            integer array pascalLine ( 1 :: n );
            pascalLine( 1 ) := 1;
            for line := 1 until n do begin
                for i := line - 1 step - 1 until 2 do pascalLine( i ) := pascalLine( i - 1 ) + pascalLine( i );
                pascalLine( line ) := 1;
                write( s_w := 0, " " );
                for i := line until n do writeon( s_w := 0, "   " );
                for i := 1 until line do writeon( i_w := 6, s_w := 0, pascalLine( i ) )
            end for_line ;
        end printPascalTriangle ;

    printPascalTriangle( 8 )

end.


-------------------- PASCAL'S TRIANGLE -------------------

-- pascal :: Generator [[Int]]
on pascal()
    script nextRow
        on |λ|(row)
            zipWith(my plus, {0} & row, row & {0})
        end |λ|
    end script
    iterate(nextRow, {1})
end pascal

--------------------------- TEST -------------------------
on run
    showPascal(take(7, pascal()))
end run

------------------------ FORMATTING ----------------------

-- showPascal :: [[Int]] -> String
on showPascal(xs)
    set w to length of intercalate("   ", item -1 of xs)
    script align
        on |λ|(x)
            |center|(w, space, intercalate("   ", x))
        end |λ|
    end script
    unlines(map(align, xs))
end showPascal

------------------------- GENERIC ------------------------

-- center :: Int -> Char -> String -> String
on |center|(n, cFiller, strText)
    set lngFill to n - (length of strText)
    if lngFill > 0 then
        set strPad to replicate(lngFill div 2, cFiller) as text
        set strCenter to strPad & strText & strPad
        if lngFill mod 2 > 0 then
            cFiller & strCenter
        else
            strCenter
        end if
    else
        strText
    end if
end |center|

-- intercalate :: String -> [String] -> String
on intercalate(sep, xs)
    set {dlm, my text item delimiters} to ¬
        {my text item delimiters, sep}
    set s to xs as text
    set my text item delimiters to dlm
    return s
end intercalate

-- iterate :: (a -> a) -> a -> Generator [a]
on iterate(f, x)
    script
        property v : missing value
        property g : mReturn(f)'s |λ|
        on |λ|()
            if missing value is v then
                set v to x
            else
                set v to g(v)
            end if
            return v
        end |λ|
    end script
end iterate

-- length :: [a] -> Int
on |length|(xs)
    set c to class of xs
    if list is c or string is c then
        length of xs
    else
        2 ^ 30 -- (simple proxy for non-finite)
    end if
end |length|

-- map :: (a -> b) -> [a] -> [b]
on map(f, xs)
    tell mReturn(f)
        set lng to length of xs
        set lst to {}
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map

-- min :: Ord a => a -> a -> a
on min(x, y)
    if y < x then
        y
    else
        x
    end if
end min

-- mReturn :: First-class m => (a -> b) -> m (a -> b)
on mReturn(f)
    -- 2nd class handler function lifted into 1st class script wrapper.
    if script is class of f then
        f
    else
        script
            property |λ| : f
        end script
    end if
end mReturn

-- plus :: Num -> Num -> Num
on plus(a, b)
    a + b
end plus

-- Egyptian multiplication - progressively doubling a list, appending
-- stages of doubling to an accumulator where needed for binary
-- assembly of a target length
-- replicate :: Int -> a -> [a]
on replicate(n, a)
    set out to {}
    if n < 1 then return out
    set dbl to {a}

    repeat while (n > 1)
        if (n mod 2) > 0 then set out to out & dbl
        set n to (n div 2)
        set dbl to (dbl & dbl)
    end repeat
    return out & dbl
end replicate

-- take :: Int -> [a] -> [a]
-- take :: Int -> String -> String
on take(n, xs)
    set c to class of xs
    if list is c then
        if 0 < n then
            items 1 thru min(n, length of xs) of xs
        else
            {}
        end if
    else if string is c then
        if 0 < n then
            text 1 thru min(n, length of xs) of xs
        else
            ""
        end if
    else if script is c then
        set ys to {}
        repeat with i from 1 to n
            set end of ys to xs's |λ|()
        end repeat
        return ys
    else
        missing value
    end if
end take

-- unlines :: [String] -> String
on unlines(xs)
    set {dlm, my text item delimiters} to ¬
        {my text item delimiters, linefeed}
    set str to xs as text
    set my text item delimiters to dlm
    str
end unlines

-- unwords :: [String] -> String
on unwords(xs)
    set {dlm, my text item delimiters} to ¬
        {my text item delimiters, space}
    set s to xs as text
    set my text item delimiters to dlm
    return s
end unwords

-- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
on zipWith(f, xs, ys)
    set lng to min(|length|(xs), |length|(ys))
    if 1 > lng then return {}
    set xs_ to take(lng, xs) -- Allow for non-finite
    set ys_ to take(lng, ys) -- generators like cycle etc
    set lst to {}
    tell mReturn(f)
        repeat with i from 1 to lng
            set end of lst to |λ|(item i of xs_, item i of ys_)
        end repeat
        return lst
    end tell
end zipWith


pascalTriangle: function [n][
    triangle: new [[1]]

    loop 1..dec n 'x [
        'triangle ++ @[map couple (last triangle)++[0] [0]++(last triangle) 'x -> x\[0] + x\[1]]
    ]

    return triangle
]

loop pascalTriangle 10 'row [
    print pad.center join.with: " " map to [:string] row 'x -> pad.center x 5 60
]


n := 8, p0 := "1"        ; 1+n rows of Pascal's triangle
Loop %n% {
   p := "p" A_Index, %p% := v := 1, q := "p" A_Index-1
   Loop Parse, %q%, %A_Space%
      If (A_Index > 1)
         %p% .= " " v+A_LoopField, v := A_LoopField
   %p% .= " 1"
}
                         ; Triangular Formatted output
VarSetCapacity(tabs,n,Asc("`t"))
t .= tabs "`t1"
Loop %n% {
   t .= "`n" SubStr(tabs,A_Index)
   Loop Parse, p%A_Index%, %A_Space%
      t .= A_LoopField "`t`t"
}
Gui Add, Text,, %t%      ; Show result in a GUI
Gui Show
Return

GuiClose:
  ExitApp