import "/dynamic" for Enum, Struct, Tuple
import "/fmt" for Conv
import "/ioutil" for FileUtil

var nodes = [
    "Ident",
    "String",
    "Integer",
    "Sequence",
    "If",
    "Prtc",
    "Prts",
    "Prti",
    "While",
    "Assign",
    "Negate",
    "Not",
    "Mul",
    "Div",
    "Mod",
    "Add",
    "Sub",
    "Lss",
    "Leq",
    "Gtr",
    "Geq",
    "Eql",
    "Neq",
    "And",
    "Or"
]

var Node = Enum.create("Node", nodes)

var Tree = Struct.create("Tree", ["nodeType", "left", "right", "value"])

// dependency: Ordered by Node value, must remain in same order as Node enum
var Atr = Tuple.create("Atr", ["enumText", "nodeType"])

var atrs = [
    Atr.new("Identifier", Node.Ident),
    Atr.new("String", Node.String),
    Atr.new("Integer", Node.Integer),
    Atr.new("Sequence", Node.Sequence),
    Atr.new("If", Node.If),
    Atr.new("Prtc", Node.Prtc),
    Atr.new("Prts", Node.Prts),
    Atr.new("Prti", Node.Prti),
    Atr.new("While", Node.While),
    Atr.new("Assign", Node.Assign),
    Atr.new("Negate", Node.Negate),
    Atr.new("Not", Node.Not),
    Atr.new("Multiply", Node.Mul),
    Atr.new("Divide", Node.Div),
    Atr.new("Mod", Node.Mod),
    Atr.new("Add", Node.Add),
    Atr.new("Subtract", Node.Sub),
    Atr.new("Less", Node.Lss),
    Atr.new("LessEqual", Node.Leq),
    Atr.new("Greater", Node.Gtr),
    Atr.new("GreaterEqual", Node.Geq),
    Atr.new("Equal", Node.Eql),
    Atr.new("NotEqual", Node.Neq),
    Atr.new("And", Node.And),
    Atr.new("Or", Node.Or),
]

var stringPool = []
var globalNames = []
var globalValues = {}

var reportError = Fn.new { |msg| Fiber.abort("error : %(msg)") }

var makeNode = Fn.new { |nodeType, left, right| Tree.new(nodeType, left, right, 0) }

var makeLeaf = Fn.new { |nodeType, value| Tree.new(nodeType, null, null, value) }

// interpret the parse tree
var interp  // recursive function
interp = Fn.new { |x|
    if (!x) return 0
    var nt = x.nodeType
    if (nt == Node.Integer) return x.value
    if (nt == Node.Ident) return globalValues[x.value]
    if (nt == Node.String) return x.value
    if (nt == Node.Assign) {
        var n = interp.call(x.right)
        globalValues[x.left.value] = n
        return n
    }
    if (nt == Node.Add) return interp.call(x.left) +  interp.call(x.right)
    if (nt == Node.Sub) return interp.call(x.left) -  interp.call(x.right)
    if (nt == Node.Mul) return interp.call(x.left) *  interp.call(x.right)
    if (nt == Node.Div) return (interp.call(x.left) / interp.call(x.right)).truncate
    if (nt == Node.Mod) return interp.call(x.left) %  interp.call(x.right)
    if (nt == Node.Lss) return Conv.btoi(interp.call(x.left) <  interp.call(x.right))
    if (nt == Node.Gtr) return Conv.btoi(interp.call(x.left) >  interp.call(x.right))
    if (nt == Node.Leq) return Conv.btoi(interp.call(x.left) <= interp.call(x.right))
    if (nt == Node.Eql) return Conv.btoi(interp.call(x.left) == interp.call(x.right))
    if (nt == Node.Neq) return Conv.btoi(interp.call(x.left) != interp.call(x.right))
    if (nt == Node.And) return Conv.btoi(Conv.itob(interp.call(x.left)) && Conv.itob(interp.call(x.right)))
    if (nt == Node.Or)  return Conv.btoi(Conv.itob(interp.call(x.left)) || Conv.itob(interp.call(x.right)))
    if (nt == Node.Negate) return -interp.call(x.left)
    if (nt == Node.Not) return (interp.call(x.left) == 0) ? 1 : 0
    if (nt == Node.If) {
        if (interp.call(x.left) != 0) {
            interp.call(x.right.left)
        } else {
            interp.call(x.right.right)
        }
        return 0
    }
    if (nt == Node.While) {
        while (interp.call(x.left) != 0) interp.call(x.right)
        return 0
    }
    if (nt == Node.Prtc) {
        System.write(String.fromByte(interp.call(x.left)))
        return 0
    }
    if (nt == Node.Prti) {
        System.write(interp.call(x.left))
        return 0
    }
    if (nt == Node.Prts) {
        System.write(stringPool[interp.call(x.left)])
        return 0
    }
    if (nt == Node.Sequence) {
        interp.call(x.left)
        interp.call(x.right)
        return 0
    }
    reportError.call("interp: unknown tree type %(x.nodeType)")
}

var getEnumValue = Fn.new { |name|
    for (atr in atrs) {
        if (atr.enumText == name) return atr.nodeType
    }
    reportError.call("Unknown token %(name)")
}

var fetchStringOffset = Fn.new { |s|
    var d = ""
    s = s[1...-1]
    var i = 0
    while (i < s.count) {
        if (s[i] == "\\" && (i+1) < s.count) {
            if (s[i+1] == "n") {
                d = d + "\n"
                i = i + 1
            } else if (s[i+1] == "\\") {
                d = d + "\\"
                i = i + 1
            }
        } else {
            d = d + s[i]
        }
        i = i + 1
    }
    s = d
    for (i in 0...stringPool.count) {
        if (s == stringPool[i]) return i
    }
    stringPool.add(s)
    return stringPool.count - 1
}

var fetchVarOffset = Fn.new { |name|
    for (i in 0...globalNames.count) {
        if (globalNames[i] == name) return i
    }
    globalNames.add(name)
    return globalNames.count - 1
}

var lines = []
var lineCount = 0
var lineNum = 0

var loadAst  // recursive function
loadAst = Fn.new {
    var nodeType = 0
    var s = ""
    if (lineNum < lineCount) {
        var line = lines[lineNum].trimEnd(" \t")
        lineNum = lineNum + 1
        var tokens = line.split(" ").where { |s| s != "" }.toList
        var first = tokens[0]
        if (first[0] == ";") return null
        nodeType = getEnumValue.call(first)
        var le = tokens.count
        if (le == 2) {
            s = tokens[1]
        } else if (le > 2) {
            var idx = line.indexOf("\"")
            s = line[idx..-1]
        }
    }
    if (s != "") {
        var n
        if (nodeType == Node.Ident) {
            n = fetchVarOffset.call(s)
        } else if (nodeType == Node.Integer) {
            n = Num.fromString(s)
        } else if (nodeType == Node.String) {
            n = fetchStringOffset.call(s)
        } else {
            reportError.call("Unknown node type: %(s)")
        }
        return makeLeaf.call(nodeType, n)
    }
    var left  = loadAst.call()
    var right = loadAst.call()
    return makeNode.call(nodeType, left, right)
}

lines = FileUtil.readLines("ast.txt")
lineCount = lines.count
var x = loadAst.call()
interp.call(x)


    % returns true if all elements of the string array a are equal, false otherwise %
    % As Algol W procedures cannot determine the bounds of an array, the bounds     %
    % must be specified in lo and hi                                                %
    logical procedure allStringsEqual ( string(256) array a ( * )
                                      ; integer     value lo, hi
                                      ) ;
    begin
        logical same;
        integer listPos;
        same    := true;
        listPos := lo + 1;
        while same and listPos <= hi do begin
            same    := a( lo ) = a( listPos );
            listPos := listPos + 1
        end;
        same
    end allStringsEqual ;

    % returns true if the elements of the string array a are in ascending order,    %
    % false otherwise                                                               %
    % As Algol W procedures cannot determine the bounds of an array, the bounds     %
    % must be specified in lo and hi                                                %
    logical procedure ascendingOrder  ( string(256) array a ( * )
                                      ; integer     value lo, hi
                                      ) ;
    begin
        logical ordered;
        integer listPos;
        ordered := true;
        listPos := lo + 1;
        while ordered and listPos <= hi do begin
            ordered := a( listPos - 1 ) < a( listPos );
            listPos := listPos + 1
        end;
        ordered
    end ascendingOrder ;


-- allEqual :: [String] -> Bool
on allEqual(xs)
    _and(zipWith(my _equal, xs, rest of xs))
end allEqual

-- azSorted :: [String] -> Bool
on azSorted(xs)
    _and(zipWith(my azBeforeOrSame, xs, rest of xs))
end azSorted

-- _equal :: a -> a -> Bool
on _equal(a, b)
    a = b
end _equal

-- azBefore :: String -> String -> Bool
on azBeforeOrSame(a, b)
    a ≥ b
end azBeforeOrSame

-- _and :: [a] -> Bool
on _and(xs)
    foldr(_equal, true, xs)
end _and

-- TEST
on run
    set lstA to ["isiZulu", "isiXhosa", "isiNdebele", "Xitsonga", "Tshivenda", ¬
        "Setswana", "Sesotho sa Leboa", "Sesotho", "English", "Afrikaans"]

    set lstB to ["Afrikaans", "English", "Sesotho", "Sesotho sa Leboa", "Setswana", ¬
        "Tshivenda", "Xitsonga", "isiNdebele", "isiXhosa", "isiZulu"]

    set lstC to ["alpha", "alpha", "alpha", "alpha", "alpha", "alpha", "alpha", ¬
        "alpha", "alpha", "alpha"]

    {allEqual:map(allEqual, [lstA, lstB, lstC]), azSorted:map(azSorted, [lstA, lstB, lstC])}

    -- > {allEqual:{false, false, true}, azSorted:{false, true, true}}
end run

-- GENERIC FUNCTIONS

-- foldr :: (a -> b -> a) -> a -> [b] -> a
on foldr(f, startValue, xs)
    tell mReturn(f)
        set v to startValue
        set lng to length of xs
        repeat with i from lng to 1 by -1
            set v to lambda(v, item i of xs, i, xs)
        end repeat
        return v
    end tell
end foldr

-- 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 lambda(item i of xs, i, xs)
        end repeat
        return lst
    end tell
end map

-- zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
on zipWith(f, xs, ys)
    set nx to length of xs
    set ny to length of ys
    if nx < 1 or ny < 1 then
        {}
    else
        set lng to cond(nx < ny, nx, ny)
        set lst to {}
        tell mReturn(f)
            repeat with i from 1 to lng
                set end of lst to lambda(item i of xs, item i of ys)
            end repeat
            return lst
        end tell
    end if
end zipWith

-- cond :: Bool -> (a -> b) -> (a -> b) -> (a -> b)
on cond(bool, f, g)
    if bool then
        f
    else
        g
    end if
end cond

-- 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 lambda : f
        end script
    end if
end mReturn


const std = @import("std");

pub const ASTInterpreterError = error{OutOfMemory};

pub const ASTInterpreter = struct {
    output: std.ArrayList(u8),
    globals: std.StringHashMap(NodeValue),

    const Self = @This();

    pub fn init(allocator: std.mem.Allocator) Self {
        return ASTInterpreter{
            .output = std.ArrayList(u8).init(allocator),
            .globals = std.StringHashMap(NodeValue).init(allocator),
        };
    }

    // Returning `NodeValue` from this function looks suboptimal and this should
    // probably be a separate type.
    pub fn interp(self: *Self, tree: ?*Tree) ASTInterpreterError!?NodeValue {
        if (tree) |t| {
            switch (t.typ) {
                .sequence => {
                    _ = try self.interp(t.left);
                    _ = try self.interp(t.right);
                },
                .assign => try self.globals.put(
                    t.left.?.value.?.string,
                    (try self.interp(t.right)).?,
                ),
                .identifier => return self.globals.get(t.value.?.string).?,
                .kw_while => {
                    while ((try self.interp(t.left)).?.integer != 0) {
                        _ = try self.interp(t.right);
                    }
                },
                .kw_if => {
                    const condition = (try self.interp(t.left)).?.integer;
                    if (condition == 1) {
                        _ = try self.interp(t.right.?.left);
                    } else {
                        _ = try self.interp(t.right.?.right);
                    }
                },
                .less => return NodeValue{ .integer = try self.binOp(less, t.left, t.right) },
                .less_equal => return NodeValue{ .integer = try self.binOp(less_equal, t.left, t.right) },
                .greater => return NodeValue{ .integer = try self.binOp(greater, t.left, t.right) },
                .greater_equal => return NodeValue{ .integer = try self.binOp(greater_equal, t.left, t.right) },
                .add => return NodeValue{ .integer = try self.binOp(add, t.left, t.right) },
                .subtract => return NodeValue{ .integer = try self.binOp(sub, t.left, t.right) },
                .multiply => return NodeValue{ .integer = try self.binOp(mul, t.left, t.right) },
                .divide => return NodeValue{ .integer = try self.binOp(div, t.left, t.right) },
                .mod => return NodeValue{ .integer = try self.binOp(mod, t.left, t.right) },
                .equal => return NodeValue{ .integer = try self.binOp(equal, t.left, t.right) },
                .not_equal => return NodeValue{ .integer = try self.binOp(not_equal, t.left, t.right) },
                .bool_and => return NodeValue{ .integer = try self.binOp(@"and", t.left, t.right) },
                .bool_or => return NodeValue{ .integer = try self.binOp(@"or", t.left, t.right) },
                .negate => return NodeValue{ .integer = -(try self.interp(t.left)).?.integer },
                .not => {
                    const arg = (try self.interp(t.left)).?.integer;
                    const result: i32 = if (arg == 0) 1 else 0;
                    return NodeValue{ .integer = result };
                },
                .prts => _ = try self.out("{s}", .{(try self.interp(t.left)).?.string}),
                .prti => _ = try self.out("{d}", .{(try self.interp(t.left)).?.integer}),
                .prtc => _ = try self.out("{c}", .{@intCast(u8, (try self.interp(t.left)).?.integer)}),
                .string => return t.value,
                .integer => return t.value,
                .unknown => {
                    std.debug.print("\nINTERP: UNKNOWN {}\n", .{t});
                    std.os.exit(1);
                },
            }
        }

        return null;
    }

    pub fn out(self: *Self, comptime format: []const u8, args: anytype) ASTInterpreterError!void {
        try self.output.writer().print(format, args);
    }

    fn binOp(
        self: *Self,
        func: fn (a: i32, b: i32) i32,
        a: ?*Tree,
        b: ?*Tree,
    ) ASTInterpreterError!i32 {
        return func(
            (try self.interp(a)).?.integer,
            (try self.interp(b)).?.integer,
        );
    }

    fn less(a: i32, b: i32) i32 {
        return @boolToInt(a < b);
    }
    fn less_equal(a: i32, b: i32) i32 {
        return @boolToInt(a <= b);
    }
    fn greater(a: i32, b: i32) i32 {
        return @boolToInt(a > b);
    }
    fn greater_equal(a: i32, b: i32) i32 {
        return @boolToInt(a >= b);
    }
    fn equal(a: i32, b: i32) i32 {
        return @boolToInt(a == b);
    }
    fn not_equal(a: i32, b: i32) i32 {
        return @boolToInt(a != b);
    }
    fn add(a: i32, b: i32) i32 {
        return a + b;
    }
    fn sub(a: i32, b: i32) i32 {
        return a - b;
    }
    fn mul(a: i32, b: i32) i32 {
        return a * b;
    }
    fn div(a: i32, b: i32) i32 {
        return @divTrunc(a, b);
    }
    fn mod(a: i32, b: i32) i32 {
        return @mod(a, b);
    }
    fn @"or"(a: i32, b: i32) i32 {
        return @boolToInt((a != 0) or (b != 0));
    }
    fn @"and"(a: i32, b: i32) i32 {
        return @boolToInt((a != 0) and (b != 0));
    }
};

pub fn main() !void {
    var arena = std.heap.ArenaAllocator.init(std.heap.page_allocator);
    defer arena.deinit();
    const allocator = arena.allocator();

    var arg_it = std.process.args();
    _ = try arg_it.next(allocator) orelse unreachable; // program name
    const file_name = arg_it.next(allocator);
    // We accept both files and standard input.
    var file_handle = blk: {
        if (file_name) |file_name_delimited| {
            const fname: []const u8 = try file_name_delimited;
            break :blk try std.fs.cwd().openFile(fname, .{});
        } else {
            break :blk std.io.getStdIn();
        }
    };
    defer file_handle.close();
    const input_content = try file_handle.readToEndAlloc(allocator, std.math.maxInt(usize));

    var string_pool = std.ArrayList([]const u8).init(allocator);
    const ast = try loadAST(allocator, input_content, &string_pool);
    var ast_interpreter = ASTInterpreter.init(allocator);
    _ = try ast_interpreter.interp(ast);
    const result: []const u8 = ast_interpreter.output.items;
    _ = try std.io.getStdOut().write(result);
}

pub const NodeType = enum {
    unknown,
    identifier,
    string,
    integer,
    sequence,
    kw_if,
    prtc,
    prts,
    prti,
    kw_while,
    assign,
    negate,
    not,
    multiply,
    divide,
    mod,
    add,
    subtract,
    less,
    less_equal,
    greater,
    greater_equal,
    equal,
    not_equal,
    bool_and,
    bool_or,

    const from_string_map = std.ComptimeStringMap(NodeType, .{
        .{ "UNKNOWN", .unknown },
        .{ "Identifier", .identifier },
        .{ "String", .string },
        .{ "Integer", .integer },
        .{ "Sequence", .sequence },
        .{ "If", .kw_if },
        .{ "Prtc", .prtc },
        .{ "Prts", .prts },
        .{ "Prti", .prti },
        .{ "While", .kw_while },
        .{ "Assign", .assign },
        .{ "Negate", .negate },
        .{ "Not", .not },
        .{ "Multiply", .multiply },
        .{ "Divide", .divide },
        .{ "Mod", .mod },
        .{ "Add", .add },
        .{ "Subtract", .subtract },
        .{ "Less", .less },
        .{ "LessEqual", .less_equal },
        .{ "Greater", .greater },
        .{ "GreaterEqual", .greater_equal },
        .{ "Equal", .equal },
        .{ "NotEqual", .not_equal },
        .{ "And", .bool_and },
        .{ "Or", .bool_or },
    });

    pub fn fromString(str: []const u8) NodeType {
        return from_string_map.get(str).?;
    }
};

pub const NodeValue = union(enum) {
    integer: i32,
    string: []const u8,
};

pub const Tree = struct {
    left: ?*Tree,
    right: ?*Tree,
    typ: NodeType = .unknown,
    value: ?NodeValue = null,

    fn makeNode(allocator: std.mem.Allocator, typ: NodeType, left: ?*Tree, right: ?*Tree) !*Tree {
        const result = try allocator.create(Tree);
        result.* = Tree{ .left = left, .right = right, .typ = typ };
        return result;
    }

    fn makeLeaf(allocator: std.mem.Allocator, typ: NodeType, value: ?NodeValue) !*Tree {
        const result = try allocator.create(Tree);
        result.* = Tree{ .left = null, .right = null, .typ = typ, .value = value };
        return result;
    }
};

const LoadASTError = error{OutOfMemory} || std.fmt.ParseIntError;

fn loadAST(
    allocator: std.mem.Allocator,
    str: []const u8,
    string_pool: *std.ArrayList([]const u8),
) LoadASTError!?*Tree {
    var line_it = std.mem.split(u8, str, "\n");
    return try loadASTHelper(allocator, &line_it, string_pool);
}

fn loadASTHelper(
    allocator: std.mem.Allocator,
    line_it: *std.mem.SplitIterator(u8),
    string_pool: *std.ArrayList([]const u8),
) LoadASTError!?*Tree {
    if (line_it.next()) |line| {
        var tok_it = std.mem.tokenize(u8, line, " ");
        const tok_str = tok_it.next().?;
        if (tok_str[0] == ';') return null;

        const node_type = NodeType.fromString(tok_str);
        const pre_iteration_index = tok_it.index;

        if (tok_it.next()) |leaf_value| {
            const node_value = blk: {
                switch (node_type) {
                    .integer => break :blk NodeValue{ .integer = try std.fmt.parseInt(i32, leaf_value, 10) },
                    .identifier => break :blk NodeValue{ .string = leaf_value },
                    .string => {
                        tok_it.index = pre_iteration_index;
                        const str = tok_it.rest();
                        var string_literal = try std.ArrayList(u8).initCapacity(allocator, str.len);
                        var escaped = false;
                        // Truncate double quotes
                        for (str[1 .. str.len - 1]) |ch| {
                            if (escaped) {
                                escaped = false;
                                switch (ch) {
                                    'n' => try string_literal.append('\n'),
                                    '\\' => try string_literal.append('\\'),
                                    else => unreachable,
                                }
                            } else {
                                switch (ch) {
                                    '\\' => escaped = true,
                                    else => try string_literal.append(ch),
                                }
                            }
                        }
                        try string_pool.append(string_literal.items);
                        break :blk NodeValue{ .string = string_literal.items };
                    },
                    else => unreachable,
                }
            };
            return try Tree.makeLeaf(allocator, node_type, node_value);
        }

        const left = try loadASTHelper(allocator, line_it, string_pool);
        const right = try loadASTHelper(allocator, line_it, string_pool);
        return try Tree.makeNode(allocator, node_type, left, right);
    } else {
        return null;
    }
}


const{ var _n=-1; var[proxy]N=fcn{ _n+=1 }; }  // enumerator
const FETCH=N, STORE=N, PUSH=N, ADD=N,  SUB=N,  MUL=N, DIV=N, MOD=N,
      LT=N,    GT=N,    LE=N,   GE=N,   EQ=N,   NE=N,
      AND=N,   OR=N,    NEG=N,  NOT=N,
      JMP=N,   JZ=N,    PRTC=N, PRTS=N, PRTI=N, HALT=N;
const nd_String=N, nd_Sequence=N, nd_If=N, nd_While=N;
var [const]
   all_syms=Dictionary(
      "Identifier"  ,FETCH,       "String"      ,nd_String,
      "Integer"     ,PUSH,        "Sequence"    ,nd_Sequence,
      "If"          ,nd_If,       "Prtc"        ,PRTC,
      "Prts"        ,PRTS,        "Prti"        ,PRTI,
      "While"       ,nd_While,    "Assign"      ,STORE,
      "Negate"      ,NEG,         "Not"         ,NOT,
      "Multiply"    ,MUL,         "Divide"      ,DIV,
      "Mod"         ,MOD,         "Add"         ,ADD,
      "Subtract"    ,SUB,         "Less"        ,LT,
      "LessEqual"   ,LE,          "Greater"     ,GT,
      "GreaterEqual",GE,          "Equal"       ,EQ,
      "NotEqual"    ,NE,          "And"         ,AND,
      "Or"          ,OR,	  "halt"	,HALT),
   bops=Dictionary(ADD,'+, SUB,'-, MUL,'*, DIV,'/, MOD,'%,
		   LT,'<, GT,'>, LE,'<=, GE,'>=, NE,'!=, EQ,'==, NE,'!=);

class Node{
   fcn init(_node_type, _value, _left=Void, _right=Void){
      var type=_node_type, left=_left, right=_right, value=_value;
   }
}

fcn runNode(node){
   var vars=Dictionary();  // fcn local static var
   if(Void==node) return();
   switch(node.type){
      case(PUSH,nd_String){ return(node.value) }
      case(FETCH){ return(vars[node.value]) }
      case(STORE){ vars[node.left.value]=runNode(node.right); return(Void); }
      case(nd_If){
         if(runNode(node.left)) runNode(node.right.left);
	 else                   runNode(node.right.right);
      }
      case(nd_While)
         { while(runNode(node.left)){ runNode(node.right) } return(Void) }
      case(nd_Sequence){ runNode(node.left); runNode(node.right); return(Void) }
      case(PRTC)       { print(runNode(node.left).toAsc()) }
      case(PRTI,PRTS)  { print(runNode(node.left)) }
      case(NEG)        { return(-runNode(node.left)) }
      case(NOT)        { return(not runNode(node.left)) }
      case(AND)        { return(runNode(node.left) and runNode(node.right)) }
      case(OR)         { return(runNode(node.left) or  runNode(node.right)) }
      else{
	 if(op:=bops.find(node.type))
	    return(op(runNode(node.left),runNode(node.right)));
	 else throw(Exception.AssertionError(
	    "Unknown node type: %d".fmt(node.type)))
      }
   }
   Void
}


allEqual?: function [lst] -> 1 = size unique lst
ascending?: function [lst] -> lst = sort lst

lists: [
    ["abc" "abc" "abc"]
    ["abc" "abd" "abc"]
    ["abc" "abd" "abe"]
    ["abc" "abe" "abd"]
]

loop lists 'l [
    print ["list:" l]
    print ["allEqual?" allEqual? l]
    print ["ascending?" ascending? l "\n"]
]


# syntax: GAWK -f COMPARE_A_LIST_OF_STRINGS.AWK
BEGIN {
    main("AA,BB,CC")
    main("AA,AA,AA")
    main("AA,CC,BB")
    main("AA,ACB,BB,CC")
    main("single_element")
    exit(0)
}
function main(list,  arr,i,n,test1,test2) {
    test1 = 1 # elements are identical
    test2 = 1 # elements are in ascending order
    n = split(list,arr,",")
    printf("\nlist:")
    for (i=1; i<=n; i++) {
      printf(" %s",arr[i])
      if (i > 1) {
        if (arr[i-1] != arr[i]) {
          test1 = 0 # elements are not identical
        }
        if (arr[i-1] >= arr[i]) {
          test2 = 0 # elements are not in ascending order
        }
      }
    }
    printf("\n%d\n%d\n",test1,test2)
}


AllEq ← ⍋≡⍒
Asc ← ¬∘AllEq∧∧≡⊢

•Show AllEq ⟨"AA", "AA", "AA", "AA"⟩
•Show Asc ⟨"AA", "AA", "AA", "AA"⟩

•Show AllEq ⟨"AA", "ACB", "BB", "CC"⟩
•Show Asc ⟨"AA", "ACB", "BB", "CC"⟩


#include <stdbool.h>
#include <string.h>

static bool
strings_are_equal(const char **strings, size_t nstrings)
{
    for (size_t i = 1; i < nstrings; i++)
        if (strcmp(strings[0], strings[i]) != 0)
            return false;
    return true;
}

static bool
strings_are_in_ascending_order(const char **strings, size_t nstrings)
{
    for (size_t i = 1; i < nstrings; i++)
        if (strcmp(strings[i - 1], strings[i]) >= 0)
            return false;
    return true;
}


public static (bool lexicallyEqual, bool strictlyAscending) CompareAListOfStrings(List<string> strings) =>
    strings.Count < 2 ? (true, true) :
    (
        strings.Distinct().Count() < 2,
        Enumerable.Range(1, strings.Count - 1).All(i => string.Compare(strings[i-1], strings[i]) < 0)
    );


#include <algorithm>
#include <string>

// Bug: calling operator++ on an empty collection invokes undefined behavior.
std::all_of( ++(strings.begin()), strings.end(),
             [&](std::string a){ return a == strings.front(); } )  // All equal

std::is_sorted( strings.begin(), strings.end(),
                [](std::string a, std::string b){ return !(b < a); }) )  // Strictly ascending


;; Checks if all items in strings list are equal (returns true if list is empty)
(every?	(fn [[a nexta]] (= a nexta)) (map vector strings (rest strings))))

;; Checks strings list is in ascending order (returns true if list is empty)
(every?	(fn [[a nexta]] (<= (compare a nexta) 0)) (map vector strings (rest strings))))


       identification division.
       program-id. CompareLists.

       data division.
       working-storage section.
       78  MAX-ITEMS              value 3.
       77  i                      pic 9(2).
       01  the-list.
           05 list-items occurs MAX-ITEMS.
              10 list-item        pic x(3).
       01  results.
           05 filler              pic 9(1).
              88 equal-strings    value 1 when set to false is 0.
           05 filler              pic 9(1).
              88 ordered-strings  value 1 when set to false is 0.

       procedure division.
       main.
           move "AA BB CC" to the-list
           perform check-list
           move "AA AA AA" to the-list
           perform check-list
           move "AA CC BB" to the-list
           perform check-list
           move "AA ACBBB CC" to the-list
           perform check-list
           move "AA" to the-list
           perform check-list
           stop run
           .
       check-list.
           display "list:"
           set equal-strings to true
           set ordered-strings to true
           perform varying i from 1 by 1 until i > MAX-ITEMS
              if list-item(i) <> spaces
                 display function trim(list-item(i)), " " no advancing
                 if i < MAX-ITEMS and list-item(i + 1) <> spaces
                    if list-item(i + 1) <> list-item(i)
                       set equal-strings to false
                    end-if
                    if list-item(i + 1) <= list-item(i)
                       set ordered-strings to false
                    end-if
                 end-if
              end-if
           end-perform
           display " "
           if equal-strings
              display "... is lexically equal"
           else
              display "... is not lexically equal"
           end-if
           if ordered-strings
              display "... is in strict ascending order"
           else
              display "... is not in strict ascending order"
           end-if
           display " "
           .


(defun strings-equal-p (strings)
  (null (remove (first strings) (rest strings) :test #'string=)))

(defun strings-ascending-p (strings)
  (loop for string1 = (first strings) then string2
        for string2 in (rest strings)
        always (string-lessp string1 string2)))


void main() {
    import std.stdio, std.algorithm, std.range, std.string;

    foreach (const strings; ["AA AA AA AA", "AA ACB BB CC"].map!split) {
        strings.writeln;
        strings.zip(strings.dropOne).all!(ab => ab[0] == ab[1]).writeln;
        strings.zip(strings.dropOne).all!(ab => ab[0] < ab[1]).writeln;
        writeln;
    }
}


program Compare_a_list_of_strings;

{$APPTYPE CONSOLE}

uses
  System.SysUtils;

type
  // generic alias for use helper. The "TArray<string>" will be work too
  TListString = TArray<string>;

  TListStringHelper = record helper for TListString
    function AllEqual: boolean;
    function AllLessThan: boolean;
    function ToString: string;
  end;

{ TListStringHelper }

function TListStringHelper.AllEqual: boolean;
begin
  Result := True;
  if Length(self) < 2 then
    exit;

  var first := self[0];
  for var i := 1 to High(self) do
    if self[i] <> first then
      exit(False);
end;

function TListStringHelper.AllLessThan: boolean;
begin
  Result := True;
  if Length(self) < 2 then
    exit;

  var last := self[0];
  for var i := 1 to High(self) do
  begin
    if not (last < self[i]) then
      exit(False);
    last := self[i];
  end;
end;

function TListStringHelper.ToString: string;
begin
  Result := '[';
  Result := Result + string.join(', ', self);
  Result := Result + ']';
end;

var
  lists: TArray<TArray<string>>;

begin
  lists := [['a'], ['a', 'a'], ['a', 'b']];

  for var list in lists do
  begin
    writeln(list.ToString);
    writeln('Is AllEqual: ', list.AllEqual);
    writeln('Is AllLessThan: ', list.AllLessThan, #10);
  end;

  readln;
end.


func isSorted(xs) {
    var prev
    for x in xs {
        if prev && !(x > prev) {
            return false
        }
        prev = x
    }
    true
}

func isEqual(xs) {
    var prev
    for x in xs {
        if prev && x != prev {
            return false
        }
        prev = x
    }
    true
}


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

extension helper
{
    isEqual()
        = nil == self.seekEach(self.FirstMember, (n,m => m.equal:n.Inverted ));

    isAscending()
    {
        var former := self.enumerator();
        var later := self.enumerator();

        later.next();

        ^ nil == former.zipBy(later, (prev,next => next <= prev )).seekEach:(b => b)
    }
}

testCases
    = new string[][]{
         new string[]{"AA","BB","CC"},
         new string[]{"AA","AA","AA"},
         new string[]{"AA","CC","BB"},
         new string[]{"AA","ACB","BB","CC"},
         new string[]{"single_element"}};

public program()
{
    testCases.forEach:(list)
        {
            console.printLine(list.asEnumerable()," all equal - ",list.isEqual());
            console.printLine(list.asEnumerable()," ascending - ",list.isAscending())
        };

    console.readChar()
}


defmodule RC do
  def compare_strings(strings) do
    {length(Enum.uniq(strings))<=1, strict_ascending(strings)}
  end

  defp strict_ascending(strings) when length(strings) <= 1, do: true
  defp strict_ascending([first, second | _]) when first >= second, do: false
  defp strict_ascending([_, second | rest]), do: strict_ascending([second | rest])
end

lists = [ ~w(AA AA AA AA), ~w(AA ACB BB CC), ~w(AA CC BB), [], ["XYZ"] ]
Enum.each(lists, fn list ->
  IO.puts "#{inspect RC.compare_strings(list)}\t<= #{inspect list} "
end)


-module(compare_strings).

-export([all_equal/1,all_incr/1]).

all_equal(Strings) ->
	all_fulfill(fun(S1,S2) -> S1 == S2 end,Strings).

all_incr(Strings) ->
	all_fulfill(fun(S1,S2) -> S1 < S2 end,Strings).

all_fulfill(Fun,Strings) ->
	lists:all(fun(X) -> X end,lists:zipwith(Fun, lists:droplast(Strings), tl(Strings)) ).


let allEqual strings = Seq.isEmpty strings || Seq.forall (fun x -> x = Seq.head strings) (Seq.tail strings)
let ascending strings = Seq.isEmpty strings || Seq.forall2 (fun x y -> x < y) strings (Seq.tail strings)


\ linked list of strings creators
: ,"       ( -- )  [CHAR] " WORD  [email protected] 1+ ALLOT  ;             \ Parse input stream until " and write into next available memory
: [[       ( -- )  0 C, ;                                    \ begin a list. write a 0 into next memory byte (null string)
: ]]       ( -- )  [[ ;                                      \ end list with same null string

: nth      ( n list -- addr) swap 0 do count + loop ;        \ return address of the Nth item in a list

: items    ( list -- n )                                     \ return the number of items in a list
          0 >R
          BEGIN
            COUNT + DUP
            R> 1+ >R
          0= UNTIL
          DROP
          R> 1- ;

: compare$ ( $1 $2 -- -n|0|n )  count rot count compare ;    \ compare is an ANS Forth word. returns 0 if $1=$2

: compare[]   ( list n1 n2 -- flag)                          \ compare items n1 and n2 in list
            ROT dup >R nth ( -- $1)
            swap r> nth    ( -- $1 $2)
            compare$ ;

\ create our lexical operators
: LEX=     ( list -- flag)
           0                                                 \ place holder for the flag
           over items 1
           DO
              over I  I 1+ compare[] +                       \ we sum the comparison results on the stack
           LOOP
           nip 0= ;

: LEX<     ( list -- flag)
           0                                                 \ place holder for the flag
           over items 1
           DO
              over I  I 1+ compare[] 0< NOT +
           LOOP
           nip 0= ;

\ make some lists
create strings  [[ ," ENTRY 4" ," ENTRY 3" ," ENTRY 2" ," ENTRY 1" ]]
create strings2 [[ ," the same" ," the same" ," the same" ]]
create strings3 [[ ," AAA" ," BBB" ," CCC" ," DDD" ]]


      INTEGER MANY,LONG
      PARAMETER (LONG = 6,MANY = 4)	!Adjust to suit.
      CHARACTER*(LONG) STRINGS(MANY)	!A list of text strings.
      STRINGS(1) = "Fee"
      STRINGS(2) = "Fie"
      STRINGS(3) = "Foe"
      STRINGS(4) = "Fum"
      IF (ALL(STRINGS(1:MANY - 1) .LT. STRINGS(2:MANY))) THEN
        WRITE (6,*) MANY," strings: strictly increasing in order."
       ELSE
        WRITE (6,*) MANY," strings: not strictly increasing in order."
      END IF
      IF (ALL(STRINGS(1:MANY - 1) .EQ. STRINGS(2:MANY))) THEN
        WRITE (6,*) MANY," strings: all equal."
       ELSE
        WRITE (6,*) MANY," strings: not all equal."
      END IF
      END


' FB 1.05.0 Win64

Function AllEqual(strings() As String) As Boolean
   Dim length As Integer = UBound(strings) - LBound(strings) + 1
   If length < 2 Then Return False
   For i As Integer = LBound(strings) + 1 To UBound(strings)
     If strings(i - 1) <> strings(i) Then Return False
   Next
   Return True
End Function

Function AllAscending(strings() As String) As Boolean
   Dim length As Integer = UBound(strings) - LBound(strings) + 1
   If length < 2 Then Return False
   For i As Integer = LBound(strings) + 1 To UBound(strings)
     If strings(i - 1) >= strings(i) Then Return False
   Next
   Return True
End Function


package cmp

func AllEqual(strings []string) bool {
	for _, s := range strings {
		if s != strings[0] {
			return false
		}
	}
	return true
}

func AllLessThan(strings []string) bool {
	for i := 1; i < len(strings); i++ {
		if !(strings[i - 1] < s) {
			return false
		}
	}
	return true
}


var list = {"a", "b", "c", "d"}

var isHomogeneous = list.toSet().Count < 2
var isOrderedSet = list.toSet().order().toList() == list


allEqual :: Eq a => [a] -> Bool
allEqual xs = and $ zipWith (==) xs (tail xs)

allIncr :: Ord a => [a] -> Bool
allIncr xs = and $ zipWith (<) xs (tail xs)


#
# list-compare.icn
#
link fullimag

procedure main()
   L1 := ["aa"]
   L2 := ["aa", "aa", "aa"]
   L3 := ["", "aa", "ab", "ac"]
   L4 := ["aa", "bb", "cc"]
   L5 := ["cc", "bb", "aa"]

   every L := (L1 | L2 | L3 | L4 | L5) do {
      writes(fullimage(L))
      writes(": equal ")
      writes(if allequal(L) then "true" else "false")
      writes(", ascending ")
      write(if ascending(L) then "true" else "false")
   }
end

# test for all identical
procedure allequal(L)
   if *L < 2 then return
   a := L[1]
   every b := L[2 to *L] do {
      if a ~== b then fail
      a := b
   }
   return
end

# test for strictly ascending
procedure ascending(L)
   if *L < 2 then return
   a := L[1]
   every b := L[2 to *L] do {
      if a >>= b then fail
      a := b
   }
   return
end


import java.util.Arrays;

public class CompareListOfStrings {

    public static void main(String[] args) {
        String[][] arr = {{"AA", "AA", "AA", "AA"}, {"AA", "ACB", "BB", "CC"}};
        for (String[] a : arr) {
            System.out.println(Arrays.toString(a));
            System.out.println(Arrays.stream(a).distinct().count() < 2);
            System.out.println(Arrays.equals(Arrays.stream(a).distinct().sorted().toArray(), a));
        }
    }
}


function allEqual(a) {
  var out = true, i = 0;
  while (++i<a.length) {
    out = out && (a[i-1] === a[i]);
  } return out;
}

function azSorted(a) {
  var out = true, i = 0;
  while (++i<a.length) {
    out = out && (a[i-1] < a[i]);
  } return out;
}

var e = ['AA', 'AA', 'AA', 'AA'], s = ['AA', 'ACB', 'BB', 'CC'], empty = [], single = ['AA'];
console.log(allEqual(e)); // true
console.log(allEqual(s)); // false
console.log(allEqual(empty)); // true
console.log(allEqual(single)); // true
console.log(azSorted(e)); // false
console.log(azSorted(s)); // true
console.log(azSorted(empty)); // true
console.log(azSorted(single)); // true


# Are the strings all equal?
def lexically_equal:
  . as $in
  | reduce range(0;length-1) as $i
      (true; if . then $in[$i] == $in[$i + 1] else false end);

# Are the strings in strictly ascending order?
def lexically_ascending:
  . as $in
  | reduce range(0;length-1) as $i
      (true; if . then $in[$i] < $in[$i + 1] else false end);


/* Compare list of strings, in Jsish */
function allEqual(a) {
  var out = true, i = 0;
  while (++i<a.length) {
    out = out && (a[i-1] === a[i]);
  } return out;
}

function allAscending(a) {
  var out = true, i = 0;
  while (++i<a.length) {
    out = out && (a[i-1] < a[i]);
  } return out;
}

if (allEqual(strings)) puts("strings array all equal");
else puts("strings array not all equal");

if (allAscending(strings)) puts("strings array in strict ascending order");
else puts("strings array not in strict ascending order");


allequal(arr::AbstractArray) = isempty(arr) || all(x -> x == first(arr), arr)

test = [["RC", "RC", "RC"], ["RC", "RC", "Rc"], ["RA", "RB", "RC"],
       ["RC"], String[], ones(Int64, 4), 1:4]

for v in test
    println("\n# Testing $v:")
    println("The elements are $("not " ^ !allequal(v))all equal.")
    println("The elements are $("not " ^ !issorted(v))strictly increasing.")
end


// version 1.0.6

fun areEqual(strings: Array<String>): Boolean {
    if (strings.size < 2) return true
    return (1 until strings.size).all { strings[it] == strings[it - 1] }
}

fun areAscending(strings: Array<String>): Boolean {
    if (strings.size < 2) return true
    return (1 until strings.size).all { strings[it] > strings[it - 1] }
}

// The strings are given in the command line arguments

fun main(args: Array<String>) {
    println("The strings are : ${args.joinToString()}")
    if (areEqual(args)) println("They are all equal")
    else if (areAscending(args)) println("They are in strictly ascending order")
    else println("They are neither equal nor in ascending order")
}


{def allsame
 {def allsame.r
  {lambda {:s :n :i}
   {if {= :i :n}
    then true
    else {if {not {W.equal? {A.get :i :s} {A.get 0 :s}}}
    then false
    else {allsame.r :s :n {+ :i 1}} }}}}
 {lambda {:s}
  {allsame.r :s {- {A.length :s} 1} 0} }}
-> allsame

{def strict_order
 {def strict_order.r
  {lambda {:s :n :i}
   {if {= :i :n}
    then true
    else {if {W.inforequal? {A.get :i :s} {A.get {- :i 1} :s}}
    then false
    else {strict_order.r :s :n {+ :i 1}}}} }}
 {lambda {:s}
  {if {= {A.length :s} 1}
   then true
   else {strict_order.r :s {A.length :s} 1} }}}
-> strict_order

{S.map allsame
       {A.new AA BB CC}
       {A.new AA AA AA}
       {A.new AA CC BB}
       {A.new AA ACB BB CC}
       {A.new single}
} -> false true false false true

{S.map strict_order
       {A.new AA BB CC}
       {A.new AA AA AA}
       {A.new AA CC BB}
       {A.new AA ACB BB CC}
       {A.new single}
} -> true false false true true


function identical(t_str)
    _, fst = next(t_str)
    if fst then
        for _, i in pairs(t_str) do
            if i ~= fst then return false end
        end
    end
    return true
end

function ascending(t_str)
    prev = false
    for _, i in ipairs(t_str) do
        if prev and prev >= i then return false end
        prev = i
    end
    return true
end

function check(str)
    t_str = {}
    for i in string.gmatch(str, "[%a_]+") do
        table.insert(t_str, i)
    end
    str = str .. ": "
    if not identical(t_str) then str = str .. "not " end
    str = str .. "identical and "
    if not ascending(t_str) then str = str .. "not " end
    print(str .. "ascending.")
end

check("ayu dab dog gar panda tui yak")
check("oy oy oy oy oy oy oy oy oy oy")
check("somehow   somewhere  sometime")
check("Hoosiers")
check("AA,BB,CC")
check("AA,AA,AA")
check("AA,CC,BB")
check("AA,ACB,BB,CC")
check("single_element")


Module CheckIt {
      Function Equal(Strings){
            k=Each(Strings, 2, -1)
            a$=Array$(Strings, 0)
            =True
            While k {
                  =False
                  if a$<>array$(k) then exit
                  =True
            }
      }
      Function LessThan(Strings){
            =True
            if len(Strings)<2 then exit
            k=Each(Strings, 2)
            a$=Array$(Strings, 0)
            While k {
                  =False
                  if a$>=array$(k) then exit
                  a$=array$(k)
                  =True
            }
      }

      Print Equal(("alfa","alfa","alfa", "alfa"))=True
      Print Equal(("alfa",))=True
      Dim A$(10)="alfa"
      Print Equal(A$())=True
      Print Equal(("alfa1","alfa2","alfa3", "alfa4"))=False

      Print LessThan(("alfa1","alfa2","alfa3", "alfa4"))=True
      Print LessThan(("alfa1",))=true
      alfa$=Lambda$ k=1 ->{=String$("*", k) : k++}
      Dim A$(20)<<alfa$()
      Print LessThan(A$())=True
      A$(5)=""
      Print LessThan(A$())=False
}
Checkit


lexEqual := proc(lst)
	local i:
	for i from 2 to numelems(lst) do
		if lst[i-1] <> lst[i] then return false: fi:
	od:
	return true:
end proc:
lexAscending := proc(lst)
	local i:
	for i from 2 to numelems(lst) do
		if StringTools:-Compare(lst[i],lst[i-1]) then return false: fi:
	od:
	return true:
end proc:
tst := ["abc","abc","abc","abc","abc"]:
lexEqual(tst):
lexAscending(tst):


-- define list of list of strings (nested vector of vectors of strings)
-- Mathcad vectors are single column arrays.
-- The following notation is for convenience in writing arrays in text form.
-- Mathcad array input is normally via Mathcad's array operator or via one of the
--   array-builder functions, such as stack or augment.
-- "," between vector elements indicates a new row.
-- " " between vector elements indicates a new column.

list:=["AA","AA","AA"],["AA","BB","CC"],["AA","CC","BB"],["CC","BB","AA"],["AA","ACB","BB","CC"],["AA"]]

-- define functions head and rest that return the first value in a list (vector)
-- and the list excluding the first element, respectively.

head(v):=if(IsArray(v),v[0,v)
rest(v):=if(rows(v)>1,submatrix(v,1,rows(v)-1,0,0),0)

-- define a function oprel that iterates through a list (vector) applying a comparison operator op to each pair of elements at the top of the list.
-- Returns immediately with false (0) if a comparison fails.

oprel(op,lst,val):=if(op(val,head(lst)),if(rows(lst)>1,oprel(op,rest(lst),head(lst)),1),0)

oprel(op,lst):=if(rows(lst)>1,oprel(op,rest(lst),head(lst)),1)

-- define a set of boolean comparison functions
-- transpose represents Mathcad's transpose operator
-- vectorize represents Mathcad's vectorize operator

eq(a,b):=a=b    (transpose(vectorize(oprel,list))) = [1 0 0 0 0 1]  -- equal
lt(a,b):=a<b    (transpose(vectorize(oprel,list))) = [0 1 0 0 1 1]  -- ascending

-- oprel, eq and lt also work with numeric values

list:=[11,11,11],[11,22,33],[11,33,22],[33,22,11],[11,132,22,33],[11]]


data1 = {"aaa", "aaa", "aab"};
Apply[Equal, data]
OrderedQ[data]


alist = {'aa', 'aa', 'aa'}
all(strcmp(alist,alist{1}))


// a function to test if a list of strings are equal
def stringsEqual(stringList)
	// if the list is empty, return true
	if (len(stringList) = 0)
		return true
	end

	// otherwise get the first value and check for equality
	toCompare = stringList[0]
	equal = true
	for (i = 1) (equal && (i < len(stringList))) (i = i + 1)
		equal = (toCompare = stringList[i])
	end for

	// return whether the strings are equal or not
	return equal
end

// a function to test if a list of strings are are less than each other
def stringsLessThan(stringList)
	// if the list is empty, return true
	if (len(stringList) = 0)
		return true
	end

	// otherwise get the first value and check for less than
	toCompare = stringList[0]
	lessThan = true
	for (i = 1) (lessThan && (i < len(stringList))) (i = i + 1)
		lessThan = (toCompare < stringList[i])
		toCompare = stringList[i]
	end for

	// return whether the string were less than each other or not
	return lessThan
end


/* NetRexx */
options replace format comments java crossref symbols nobinary

runSample(arg)
return

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method isEqual(list = Rexx[]) public static binary returns boolean
  state = boolean (1 == 1) -- default to true
  loop ix = 1 while ix < list.length
    state = list[ix - 1] == list[ix]
    if \state then leave ix
    end ix
  return state

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method isAscending(list = Rexx[]) public static binary returns boolean
  state = boolean (1 == 1) -- default to true
  loop ix = 1 while ix < list.length
    state = list[ix - 1] << list[ix]
    if \state then leave ix
    end ix
  return state

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method runSample(arg) private static

  samples = [ -
      ['AA', 'BB', 'CC'] -
    , ['AA', 'AA', 'AA'] -
    , ['AA', 'CC', 'BB'] -
    , ['single_element'] -
    ]

  loop ix = 0 while ix < samples.length
    sample = samples[ix]
    if isEqual(sample)     then eq  = 'elements are identical'
                           else eq  = 'elements are not identical'
    if isAscending(sample) then asc = 'elements are in ascending order'
                           else asc = 'elements are not in ascending order'
    say 'List:' Arrays.toString(sample)
    say '  'eq
    say '  'asc
    end ix
  return


func allEqual(s: openArray[string]): bool =

  for i in 1..s.high:
    if s[i] != s[0]:
      return false
  result = true

func ascending(s: openArray[string]): bool =

  for i in 1..s.high:
    if s[i] <= s[i - 1]:
      return false
  result = true

doAssert allEqual(["abc", "abc", "abc"])
doAssert not allEqual(["abc", "abd", "abc"])

doAssert ascending(["abc", "abd", "abe"])
doAssert not ascending(["abc", "abe", "abd"])

doAssert allEqual(["abc"])
doAssert ascending(["abc"])


open List;;

let analyze cmp l  =
  let rec analyze' l prevs =
    match l with
    [] -> true
    | [s] -> cmp prevs s
    | s::rest -> (cmp prevs s) && (analyze' rest s)
  in analyze' (List.tl l) (List.hd l)
;;

let isEqual     = analyze (=) ;;
let isAscending = analyze (<) ;;

let test sample =
   List.iter print_endline sample;
   if (isEqual sample)
       then (print_endline "elements are identical")
       else (print_endline "elements are not identical");
   if (isAscending sample)
	     then print_endline "elements are in ascending order"
         else print_endline "elements are not in ascending order";;

let lasc =   ["AA";"BB";"CC";"EE"];;
let leq =    ["AA";"AA";"AA";"AA"];;
let lnoasc = ["AA";"BB";"EE";"CC"];;

List.iter test [lasc;leq;lnoasc];;


: lexEqual   asSet size 1 <= ;
: lexCmp(l)  l l right( l size 1- ) zipWith(#<) and ;


/* REXX ---------------------------------------------------------------
* 28.06.2014 Walter Pachl
*--------------------------------------------------------------------*/
Call test 'ABC',.list~of('AA','BB','CC')
Call test 'AAA',.list~of('AA','AA','AA')
Call test 'ACB',.list~of('AA','CC','BB')
Exit

test: Procedure
Use Arg name,list
all_equal=1
increasing=1
Do i=0 To list~items-2
  i1=i+1
  Select
    When list[i1]==list[i] Then increasing=0
    When list[i1]<<list[i] Then Do
                                all_equal=0
                                increasing=0
                                End
    When list[i1]>>list[i] Then all_equal=0
    End
  End
Select
  When all_equal Then
    Say 'List' name': all elements are equal'
  When increasing Then
    Say 'List' name': elements are in increasing order'
  Otherwise
    Say 'List' name': neither equal nor in increasing order'
  End
Return


use List::Util 1.33 qw(all);

all { $strings[0] eq $strings[$_] } 1..$#strings  # All equal
all { $strings[$_-1] lt $strings[$_] } 1..$#strings  # Strictly ascending


with javascript_semantics
function allsame(sequence s)
    for i=2 to length(s) do
        if s[i]!=s[1] then return false end if
    end for
    return true
end function

function strict_order(sequence s)
    for i=2 to length(s) do
        if s[i]<=s[i-1] then return false end if
    end for
    return true
end function

procedure test(sequence s)
    printf(1,"%-22V allsame:%5t, strict_order:%5t\n",{s,allsame(s),strict_order(s)})
end procedure

test({"AA","BB","CC"})
test({"AA","AA","AA"})
test({"AA","CC","BB"})
test({"AA","ACB","BB","CC"})
test({"single_element"})


include ..\Utilitys.pmt

( "alpha" "beta" "gamma" "delta" "epsilon" "zeta"
      "eta" "theta" "iota" "kappa" "lambda" "mu" )

dup dup sort ==	/# put 0 (false) in the pile, indicating that they are not in ascending order #/

drop	/# discard the result #/

dup len swap 1 get rot repeat == /# put 0 (false) in the pile, indicating that they are not repeated strings #/


main =>
  Lists = [["AA","BB","CC"],
           ["AA","AA","AA"],
           ["AA","CC","BB"],
           ["AA","ACB","BB","CC"],
           ["single_element"],
           []],
  foreach(L in Lists)
    Same = all_same(L).cond(true,false),
    Sorted = sorted(L).cond(true,false),
    printf("%-18w all_same:%-5w  sorted:%-5w\n",L,Same,Sorted)
  end.

all_same([]).
all_same([_]).
all_same([A,B|Rest]) :-
  A == B,
  all_same([B|Rest]).


*process source xref attributes or(!);
 /*--------------------------------------------------------------------
 * 01.07.2014 Walter Pachl
 *-------------------------------------------------------------------*/
 clist: Proc Options(main);
 Dcl (hbound) Builtin;
 Dcl sysprint Print;
 Dcl abc(3) Char(2) Init('AA','BB','CC');
 Dcl aaa(3) Char(2) Init('AA','AA','AA');
 Dcl acb(3) Char(2) Init('AA','CC','BB');
 Call test('ABC',ABC);
 Call test('AAA',AAA);
 Call test('ACB',ACB);

 test: Procedure(name,x);
 Dcl name Char(*);
 Dcl x(*) Char(*);
 Dcl (all_equal,increasing) Bit(1) Init('1'b);
 Dcl (i,i1) Bin Fixed(31);
 Dcl txt Char(50) Var;
 Do i=1 To hbound(x)-1 While(all_equal ! increasing);
  i1=i+1;
  Select;
    When(x(i1)=x(i)) increasing='0'b;
    When(x(i1)<x(i)) Do;
                     increasing='0'b;
                     all_equal='0'b;
                     End;
    Otherwise /* x(i1)>x(i) */
                     all_equal='0'b;
    End;
  End;
  Select;
    When(all_equal)  txt='all elements are equal';
    When(increasing) txt='elements are in increasing order';
    Otherwise        txt='neither equal nor in increasing order';
    End;
  Put Skip List(name!!': '!!txt);
  End;
  End;


To decide if some string things are lexically equal:
If the string things are empty, say yes.
Get a string thing from the string things.
Put the string thing's string into a canonical string.
Loop.
If the string thing is nil, say yes.
If the string thing's string is not the canonical string, say no.
Put the string thing's next into the string thing.
Repeat.

To decide if some string things are in ascending order:
If the string things' count is less than 2, say yes.
Get a string thing from the string things.
Put the string thing's next into the string thing.
Loop.
If the string thing is nil, say yes.
If the string thing's string is less than the string thing's previous' string, say no.
Put the string thing's next into the string thing.
Repeat.


function IsAscending ( [string[]]$Array ) { ( 0..( $Array.Count - 2 ) ).Where{ $Array[$_] -le $Array[$_+1] }.Count -eq $Array.Count - 1 }
function IsEqual     ( [string[]]$Array ) { ( 0..( $Array.Count - 2 ) ).Where{ $Array[$_] -eq $Array[$_+1] }.Count -eq $Array.Count - 1 }

IsAscending 'A', 'B', 'B', 'C'
IsAscending 'A', 'C', 'B', 'C'
IsAscending 'A', 'A', 'A', 'A'

IsEqual     'A', 'B', 'B', 'C'
IsEqual     'A', 'C', 'B', 'C'
IsEqual     'A', 'A', 'A', 'A'


los(["AA","BB","CC"]).
los(["AA","AA","AA"]).
los(["AA","CC","BB"]).
los(["AA","ACB","BB","CC"]).
los(["single_element"]).

lexically_equal(S,S,S).
in_order(G,L,G) :- compare(<,L,G).

test_list(List) :-
    List = [L|T],
    write('for list '), write(List), nl,
    (foldl(lexically_equal, T, L, _)
        -> writeln('The items in the list ARE lexically equal')
        ; writeln('The items in the list are NOT lexically equal')),
    (foldl(in_order, T, L, _)
        -> writeln('The items in the list ARE in ascending order')
        ; writeln('The items in the list are NOT in ascending order')),
    nl.

test :- forall(los(List), test_list(List)).


EnableExplicit
DataSection
  Data.s ~"AA\tAA\tAA\nAA\tBB\tCC\nAA\tCC\tBB\nAA\tACB\tBB\tCC\nsingel_element"
EndDataSection

Macro PassFail(PF)
  If PF : PrintN("Pass") : Else : PrintN("Fail") : EndIf
EndMacro

Macro ProcRec(Proc)
  Define tf1$,tf2$ : Static chk.b : chk=#True
  tf1$=StringField(s$,c,tz$) : tf2$=StringField(s$,c+1,tz$)
  If Len(tf2$) : Proc(s$,tz$,c+1) : EndIf
EndMacro

Procedure.b IsStringsEqual(s$,tz$=~"\t",c.i=1)
  ProcRec(IsStringsEqual)
  chk & Bool(tf1$=tf2$ Or tf2$="")
  ProcedureReturn chk
EndProcedure

Procedure.b IsStringsAscending(s$,tz$=~"\t",c.i=1)
  ProcRec(IsStringsAscending)
  chk & Bool(tf1$<tf2$ Or tf2$="")
  ProcedureReturn chk
EndProcedure

Define t$,sf$,c.i,i.i,PF.b
Read.s t$ : c=CountString(t$,~"\n")
OpenConsole("Compare a list of Strings")
For i=1 To c+1
  sf$=StringField(t$,i,~"\n")
  PrintN("List : "+sf$)
  Print("Lexical test   : ") : PassFail(IsStringsEqual(sf$))
  Print("Ascending test : ") : PassFail(IsStringsAscending(sf$))
  PrintN("")
Next
Input()


all(a == nexta for a, nexta in zip(strings, strings[1:])) # All equal
all(a < nexta for a, nexta in zip(strings, strings[1:])) # Strictly ascending

len(set(strings)) == 1  # Concise all equal
sorted(strings, reverse=True) == strings  # Concise (but not particularly efficient) ascending


  [ [ true swap
      dup size 1 > while
      behead swap
      witheach
        [ over != if
            [ dip not conclude ] ] ]
      drop ]                         is allthesame ( [ --> b )

  [ [ true swap
      dup size 1 > while
      behead swap
      witheach
        [ tuck $> if
            [ dip not conclude ] ] ]
    drop ]                           is allinorder ( [ --> b )


chunks <- function (compare, xs) {
  starts = which(c(T, !compare(head(xs, -1), xs[-1]), T))
  lapply(seq(1,length(starts)-1),
         function(i) xs[starts[i]:(starts[i+1]-1)] )
}


#lang racket/base
(define ((list-stringX? stringX?) strs)
  (or (null? strs) (null? (cdr strs)) (apply stringX? strs)))
(define list-string=? (list-stringX? string=?))
(define list-string<? (list-stringX? string<?))

(module+ test
  (require tests/eli-tester)
  (test
   (list-string=? '()) => #t
   (list-string=? '("a")) => #t
   (list-string=? '("a" "a")) => #t
   (list-string=? '("a" "a" "a")) => #t
   (list-string=? '("b" "b" "a")) => #f)

  (test
   (list-string<? '()) => #t
   (list-string<? '("a")) => #t
   (list-string<? '("a" "b")) => #t
   (list-string<? '("a" "a")) => #f
   (list-string<? '("a" "b" "a")) => #f
   (list-string<? '("a" "b" "c")) => #t))


[eq] @strings  # All equal
[lt] @strings  # Strictly ascending


Red []

list1: ["asdf" "Asdf" "asdf"]
list2: ["asdf" "bsdf" "asdf"]
list3: ["asdf" "asdf" "asdf"]

all-equal?: func [list][   1 = length? unique/case list  ]
sorted?: func [list][   list == sort/case copy list ]  ;; sort without copy would modify list !

print all-equal? list1
print sorted? list1

print all-equal? list2
print sorted? list2

print all-equal? list3
print sorted? list3


/* REXX ---------------------------------------------------------------
* 28.06.2014 Walter Pachl
*--------------------------------------------------------------------*/
Call mklist 'ABC','AA','BB','CC'
Call test 'ABC'
Call mklist 'AAA','AA','AA','AA'
Call mklist 'ACB','AA','CC','BB'
Call test 'AAA'
Call test 'ACB'
Exit

mklist:
  list=arg(1)
  do i=1 by 1 To arg()-1
    call value list'.'i,arg(i+1)
    End
  Call value list'.0',i-1
  Return

test:
Parse Arg list
all_equal=1
increasing=1
Do i=1 To value(list'.0')-1 While all_equal | increasing
  i1=i+1
  Select
    When value(list'.i1')==value(list'.i') Then increasing=0
    When value(list'.i1')<<value(list'.i') Then Do
                                                all_equal=0
                                                increasing=0
                                                End
    When value(list'.i1')>>value(list'.i') Then all_equal=0
    End
  End
Select
  When all_equal Then
    Say 'List' value(list)': all elements are equal'
  When increasing Then
    Say 'List' value(list)': elements are in increasing order'
  Otherwise
    Say 'List' value(list)': neither equal nor in increasing order'
  End
Return


strings.uniq.one?                 # all equal?
strings == strings.uniq.sort      # ascending?


fn strings_are_equal(seq: &[&str]) -> bool {
    match seq {
        &[] | &[_] => true,
        &[x, y, ref tail @ ..] if x == y => strings_are_equal(&[&[y], tail].concat()),
        _ => false
    }
}

fn asc_strings(seq: &[&str]) -> bool {
    match seq {
        &[] | &[_] => true,
        &[x, y, ref tail @ ..] if x < y => asc_strings(&[&[y], tail].concat()),
        _ => false
    }
}


define equal_sl(sarr)
{
  variable n = length(sarr), a0, i;
  if (n < 2) return 1;

  a0 = sarr[0];
  _for i (1, length(sarr)-1, 1)
    if (sarr[i] != a0) return 0;

  return 1;
}
define ascending_sl(sarr) {
  variable n = length(sarr), a0, i;
  if (n < 2) return 1;

  _for i (0, length(sarr)-2, 1)
    if (sarr[i] >= sarr[i+1]) return 0;

  return 1;
}

define equal_ai(sarr) {
  if (length(sarr) < 2) return 1;
  variable s0 = sarr[0];
  return all(sarr[[1:]] == s0);
}

define ascending_ai(sarr) {
  variable la = length(sarr);
  if (la < 2) return 1;
  return all(sarr[[0:la-2]] < sarr[[1:la-1]]);
}

define atest(a) {
  () = printf("\n");
  print(a);

  () = printf("equal_sl=%d, ascending_sl=%d\n",
              equal_sl(a), ascending_sl(a));
  () = printf("equal_ai=%d, ascending_ai=%d\n",
              equal_ai(a), ascending_ai(a));
}

atest(["AA","BB","CC"]);
atest(["AA","AA","AA"]);
atest(["AA","CC","BB"]);
atest(["AA","ACB","BB","CC"]);
atest(["single_element"]);
atest(NULL);


def strings_are_equal(seq:List[String]):Boolean = seq match {
    case Nil => true
    case s::Nil => true
    case el1 :: el2 :: tail => el1==el2 && strings_are_equal(el2::tail)
}

def asc_strings(seq:List[String]):Boolean = seq match {
    case Nil => true
    case s::Nil => true
    case el1 :: el2 :: tail => el1.compareTo(el2) < 0
}


(define (compare-strings fn strs)
  (or (null? strs)                             ; returns #t on empty list
      (null? (cdr strs))                       ; returns #t on list of size 1
      (do ((fst strs (cdr fst))
           (snd (cdr strs) (cdr snd)))
        ((or (null? snd)
             (not (fn (car fst) (car snd))))
         (null? snd)))))                       ; returns #t if the snd list is empty, meaning all comparisons are exhausted

(compare-strings string=? strings) ; test for all equal
(compare-strings string<? strings) ; test for in ascending order


$ include "seed7_05.s7i";

const func boolean: allTheSame (in array string: strings) is func
  result
    var boolean: allTheSame is TRUE;
  local
    var integer: index is 0;
  begin
    for index range 2 to length(strings) until not allTheSame do
      if strings[pred(index)] <> strings[index] then
        allTheSame := FALSE;
      end if;
    end for;
  end func;

const func boolean: strictlyAscending (in array string: strings) is func
  result
    var boolean: strictlyAscending is TRUE;
  local
    var integer: index is 0;
  begin
    for index range 2 to length(strings) until not strictlyAscending do
      if strings[pred(index)] >= strings[index] then
        strictlyAscending := FALSE;
      end if;
    end for;
  end func;


analyze ["AA","BB","CC"]
analyze ["AA","AA","AA"]
analyze ["AA","CC","BB"]
analyze ["AA","ACB","BB","CC"]
analyze ["single_element"]

to analyze aList
	put "List: " & aList
	put "   " & (if allEqual(aList) then "IS" else "Is NOT") && "all equal"
	put "   " & (if isAscending(aList) then "IS" else "Is NOT") && "strictly ascending"
end analyze

to handle allEqual strings
	return the number of items in the unique items of strings is less than 2
end allEqual

to handle isAscending strings
	repeat with n = 2 to the number of items in strings
		if item n of strings isn't more than item n-1 of strings then
			return False
		end if
	end repeat
	return True
end isAscending


1..arr.end -> all{ arr[0] == arr[_] }   # all equal
1..arr.end -> all{ arr[_-1] < arr[_] }  # strictly ascending


// matcher testing if the array contains anything not equal to the first element
templates allEqual
  when <[](..1)> do 1 !
  when <[<~=$(1)>]> do 0 !
  otherwise 1 !
end allEqual

templates strictAscending
  def a: $;
  1 -> #
  when <$a::length..> do 1 !
  when <?($a($) <..~$a($+1)>)> do $ + 1 -> #
  otherwise 0 !
end strictAscending

// Of course we could just use the same kind of loop for equality
templates strictEqual
  def a: $;
  1 -> #
  when <$a::length..> do 1 !
  when <?($a($) <=$a($+1)>)> do $ + 1 -> #
  otherwise 0 !
end strictEqual


tcl::mathop::eq {*}$strings;		# All values string-equal
tcl::mathop::< {*}$strings;		# All values in strict order


Private Function IsEqualOrAscending(myList) As String
Dim i&, boolEqual As Boolean, boolAsc As Boolean

    On Error Resume Next
    If UBound(myList) > 0 Then
        If Err.Number > 0 Then
            IsEqualOrAscending = "Error " & Err.Number & " : Empty array"
            On Error GoTo 0
            Exit Function
        Else
            For i = 1 To UBound(myList)
                If myList(i) <> myList(i - 1) Then boolEqual = True
                If myList(i) <= myList(i - 1) Then boolAsc = True
            Next
        End If
    End If
    IsEqualOrAscending = "List : " & Join(myList, ",") & ", IsEqual : " & (Not boolEqual) & ", IsAscending : " & Not boolAsc
End Function


Function string_compare(arr)
	lexical = "Pass"
	ascending = "Pass"
	For i = 0 To UBound(arr)
		If i+1 <= UBound(arr) Then
			If arr(i) <> arr(i+1) Then
				lexical = "Fail"
			End If
			If arr(i) >= arr(i+1) Then
				ascending = "Fail"
			End If
		End If
	Next
	string_compare = "List: " & Join(arr,",") & vbCrLf &_
					 "Lexical Test: " & lexical & vbCrLf &_
					 "Ascending Test: " & ascending & vbCrLf
End Function

WScript.StdOut.WriteLine string_compare(Array("AA","BB","CC"))
WScript.StdOut.WriteLine string_compare(Array("AA","AA","AA"))
WScript.StdOut.WriteLine string_compare(Array("AA","CC","BB"))
WScript.StdOut.WriteLine string_compare(Array("AA","ACB","BB","CC"))
WScript.StdOut.WriteLine string_compare(Array("FF"))


fn all_equal(strings []string) bool {
	for s in strings {
		if s != strings[0] {
			return false
		}
	}
	return true
}

fn all_less_than(strings []string) bool {
	for i := 1; i < strings.len(); i++ {
		if !(strings[i - 1] < s) {
			return false
		}
	}
	return true
}


import "/sort" for Sort

var areEqual = Fn.new { |strings|
    if (strings.count < 2) return true
    return (1...strings.count).all { |i| strings[i] == strings[i-1] }
}

var areAscending = Fn.new { |strings| Sort.isSorted(strings) }

var a = ["a", "a", "a"]
var b = ["a", "b", "c"]
var c = ["a", "a", "b"]
var d = ["a", "d", "c"]
System.print("%(a) are all equal : %(areEqual.call(a))")
System.print("%(b) are ascending : %(areAscending.call(b))")
System.print("%(c) are all equal : %(areEqual.call(c))")
System.print("%(d) are ascending : %(areAscending.call(d))")


Proc allsame
   Parameters long liste
   var int result = 1
   var int cnt = GetCount(liste)
   Case cnt == 0 : Return 0
   Case cnt == 1 : Return 1
   WhileLoop 1, cnt-1
      If GetString$(liste,&loop - 1) <> GetString$(liste,&loop)
         result = 0
         BREAK
      EndIf
   EndWhile
   Return result
EndProc

Proc strict_order
   Parameters long liste
   var int result = 1
   var int cnt = GetCount(liste)
   Case cnt == 0 : Return 0
   Case cnt == 1 : Return 1
   WhileLoop 1, cnt-1
      If GetString$(liste,&loop) <= GetString$(liste,&loop - 1)
         result = 0
         BREAK
      EndIf
   EndWhile
   Return result
EndProc

cls
declare string s[4]
s[0] = "AA,BB,CC"
s[1] = "AA,AA,AA"
s[2] = "AA,CC,BB"
s[3] = "AA,ACB,BB,CC"
s[4] = "single_element"

WhileLoop 0,4
   ClearList 0
   Move("StrToList",s[&loop],",")
   Print "list:",s[&loop]
   Print "...is " + if(allsame(0), "", "not ") + "lexically equal"
   Print "...is " + if(strict_order(0), "", "not ") + "in strict ascending order"
EndWhile

ClearList 0
WaitKey
end


fcn allEQ(strings){ (not strings.filter1('!=(strings[0]))) }
fcn monoUp(strings){
   strings.len()<2 or
   strings.reduce(fcn(a,b){ if(a>=b) return(Void.Stop,False); b }).toBool()
}


module CompareStrings;
type
	Vector = array * of string;
var
	v,w: Vector;
	i: integer;
	all,ascending: boolean;
begin
	v := new Vector(3);
	v[0] := "uno";
	v[1] := "uno";
	v[2] := "uno";

	all := true;
	for i := 1 to len(v) - 1 do
		all := all & (v[i - 1] = v[i]);
	end;

	w := new Vector(3);
	w[0] := "abc";
	w[1] := "bcd";
	w[2] := "cde";
	v := w;
	ascending := true;
	for i := 1 to len(v) - 1 do
		ascending := ascending & (v[i - 1] <= v[i])
	end;

	write("all equals?: ");writeln(all);
	write("ascending?: ");writeln(ascending)
end CompareStrings.


10 FOR j=160 TO 200 STEP 10
20 RESTORE j
30 READ n
40 LET test1=1: LET test2=1
50 FOR i=1 TO n
60 READ a$
70 PRINT a$;" ";
80 IF i=1 THEN GO TO 110
90 IF p$<>a$ THEN LET test1=0
100 IF p$>=a$ THEN LET test2=0
110 LET p$=a$
120 NEXT i
130 PRINT 'test1'test2
140 NEXT j
150 STOP
160 DATA 3,"AA","BB","CC"
170 DATA 3,"AA","AA","AA"
180 DATA 3,"AA","CC","BB"
190 DATA 4,"AA","ACB","BB","CC"
200 DATA 1,"single_element"


--
-- The Rosetta Code Virtual Machine, in Ada.
--
-- It is assumed the platform on which this program is run
-- has two's-complement integers. (Otherwise one could modify
-- the vmint_to_vmsigned and vmsigned_to_vmint functions. But
-- the chances your binary integers are not two's-complement
-- seem pretty low.)
--

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line;        use Ada.Command_Line;

with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;

with Ada.Text_IO;              use Ada.Text_IO;
with Ada.Text_IO.Text_Streams; use Ada.Text_IO.Text_Streams;

with Ada.Unchecked_Conversion;

procedure VM
is
  bad_vm            : exception;
  vm_limit_exceeded : exception;
  vm_runtime_error  : exception;

  status           : Exit_Status;
  input_file_name  : Unbounded_String;
  output_file_name : Unbounded_String;
  input_file       : File_Type;
  output_file      : File_Type;

-- Some limits of this implementation. You can adjust these to taste.
  strings_size : constant := 2_048;
  stack_size   : constant := 2_048;
  data_size    : constant := 2_048;
  code_size    : constant := 32_768;

  type byte is mod 16#100#;
  type vmint is mod 16#1_0000_0000#;
  subtype vmsigned is Integer range -2_147_483_648 .. 2_147_483_647;

  op_halt  : constant byte := 0;
  op_add   : constant byte := 1;
  op_sub   : constant byte := 2;
  op_mul   : constant byte := 3;
  op_div   : constant byte := 4;
  op_mod   : constant byte := 5;
  op_lt    : constant byte := 6;
  op_gt    : constant byte := 7;
  op_le    : constant byte := 8;
  op_ge    : constant byte := 9;
  op_eq    : constant byte := 10;
  op_ne    : constant byte := 11;
  op_and   : constant byte := 12;
  op_or    : constant byte := 13;
  op_neg   : constant byte := 14;
  op_not   : constant byte := 15;
  op_prtc  : constant byte := 16;
  op_prti  : constant byte := 17;
  op_prts  : constant byte := 18;
  op_fetch : constant byte := 19;
  op_store : constant byte := 20;
  op_push  : constant byte := 21;
  op_jmp   : constant byte := 22;
  op_jz    : constant byte := 23;

  strings : array (0 .. strings_size - 1) of Unbounded_String;
  stack   : array (0 .. stack_size - 1) of vmint;
  data    : array (0 .. data_size - 1) of vmint;
  code    : array (0 .. code_size) of byte;
  sp      : vmint;
  pc      : vmint;

  output_stream : Stream_Access;

  function vmsigned_to_vmint is new Ada.Unchecked_Conversion
   (Source => vmsigned, Target => vmint);

  function vmint_to_vmsigned is new Ada.Unchecked_Conversion
   (Source => vmint, Target => vmsigned);

  function twos_complement
   (x : in vmint)
    return vmint
  is
  begin
    return (not x) + 1;
  end twos_complement;

  function vmint_to_digits
   (x : in vmint)
    return Unbounded_String
  is
    s : Unbounded_String;
    z : vmint;
  begin
    if x = 0 then
      s := To_Unbounded_String ("0");
    else
      s := To_Unbounded_String ("");
      z := x;
      while z /= 0 loop
        s := Character'Val ((z rem 10) + Character'Pos ('0')) & s;
        z := z / 10;
      end loop;
    end if;
    return s;
  end vmint_to_digits;

  function digits_to_vmint
   (s : in String)
    return vmint
  is
    zero     : constant Character := '0';
    zero_pos : constant Integer   := Character'Pos (zero);
    retval   : vmint;
  begin
    if s'Length < 1 then
      raise bad_vm with "expected a numeric literal";
    end if;
    retval := 0;
    for i in s'Range loop
      if Is_Decimal_Digit (s (i)) then
        retval :=
         (10 * retval) + vmint (Character'Pos (s (i)) - zero_pos);
      else
        raise bad_vm with "expected a decimal digit";
      end if;
    end loop;
    return retval;
  end digits_to_vmint;

  function string_to_vmint
   (s : in String)
    return vmint
  is
    retval : vmint;
  begin
    if s'Length < 1 then
      raise bad_vm with "expected a numeric literal";
    end if;
    if s (s'First) = '-' then
      if s'Length < 2 then
        raise bad_vm with "expected a numeric literal";
      end if;
      retval :=
       twos_complement (digits_to_vmint (s (s'First + 1 .. s'Last)));
    else
      retval := digits_to_vmint (s);
    end if;
    return retval;
  end string_to_vmint;

  procedure parse_header
   (s             : in     String;
    data_count    :    out vmint;
    strings_count :    out vmint)
  is
    i : Positive;
    j : Positive;
  begin
    i := s'First;
    while i <= s'Last and then not Is_Decimal_Digit (s (i)) loop
      i := i + 1;
    end loop;

    j := i;
    while j <= s'Last and then Is_Decimal_Digit (s (j)) loop
      j := j + 1;
    end loop;

    data_count := digits_to_vmint (s (i .. j - 1));

    i := j;
    while i <= s'Last and then not Is_Decimal_Digit (s (i)) loop
      i := i + 1;
    end loop;

    j := i;
    while j <= s'Last and then Is_Decimal_Digit (s (j)) loop
      j := j + 1;
    end loop;

    strings_count := digits_to_vmint (s (i .. j - 1));
  end parse_header;

  function parse_string_literal
   (s : in String)
    return Unbounded_String
  is
    t : Unbounded_String;
    i : Positive;

    --
    -- A little trick to get around mistaken highlighting on the
    -- Rosetta Code site.
    --
    quote_string : constant String    := """";
    quote        : constant Character := quote_string (1);

  begin
    t := To_Unbounded_String ("");

    i := s'First;
    while i <= s'Last and then s (i) /= quote loop
      i := i + 1;
    end loop;

    if s'Last < i or else s (i) /= quote then
      raise bad_vm with "expected a '""'";
    end if;

    i := i + 1;
    while i <= s'Last and then s (i) /= quote loop
      if s (i) /= '\' then
        Append (t, s (i));
        i := i + 1;
      elsif s'Last < i + 1 then
        raise bad_vm with "truncated string literal";
      elsif s (i + 1) = 'n' then
        Append (t, Character'Val (10));
        i := i + 2;
      elsif s (i + 1) = '\' then
        Append (t, '\');
        i := i + 2;
      else
        raise bad_vm with "unsupported escape sequence";
      end if;
    end loop;

    return t;
  end parse_string_literal;

  function name_to_opcode
   (s : in String)
    return byte
  is
    retval : byte;
  begin
    if s = "halt" then
      retval := op_halt;
    elsif s = "add" then
      retval := op_add;
    elsif s = "sub" then
      retval := op_sub;
    elsif s = "mul" then
      retval := op_mul;
    elsif s = "div" then
      retval := op_div;
    elsif s = "mod" then
      retval := op_mod;
    elsif s = "lt" then
      retval := op_lt;
    elsif s = "gt" then
      retval := op_gt;
    elsif s = "le" then
      retval := op_le;
    elsif s = "ge" then
      retval := op_ge;
    elsif s = "eq" then
      retval := op_eq;
    elsif s = "ne" then
      retval := op_ne;
    elsif s = "and" then
      retval := op_and;
    elsif s = "or" then
      retval := op_or;
    elsif s = "neg" then
      retval := op_neg;
    elsif s = "not" then
      retval := op_not;
    elsif s = "prtc" then
      retval := op_prtc;
    elsif s = "prti" then
      retval := op_prti;
    elsif s = "prts" then
      retval := op_prts;
    elsif s = "fetch" then
      retval := op_fetch;
    elsif s = "store" then
      retval := op_store;
    elsif s = "push" then
      retval := op_push;
    elsif s = "jmp" then
      retval := op_jmp;
    elsif s = "jz" then
      retval := op_jz;
    else
      raise bad_vm with ("unexpected opcode name");
    end if;
    return retval;
  end name_to_opcode;

  procedure parse_instruction
   (s       : in     String;
    address :    out vmint;
    opcode  :    out byte;
    arg     :    out vmint)
  is
    i : Positive;
    j : Positive;
  begin
    i := s'First;
    while i <= s'Last and then not Is_Decimal_Digit (s (i)) loop
      i := i + 1;
    end loop;

    j := i;
    while j <= s'Last and then Is_Decimal_Digit (s (j)) loop
      j := j + 1;
    end loop;

    address := digits_to_vmint (s (i .. j - 1));

    i := j;
    while i <= s'Last and then not Is_Letter (s (i)) loop
      i := i + 1;
    end loop;

    j := i;
    while j <= s'Last and then Is_Letter (s (j)) loop
      j := j + 1;
    end loop;

    opcode := name_to_opcode (s (i .. j - 1));

    i := j;
    while i <= s'Last and then Is_Space (s (i)) loop
      i := i + 1;
    end loop;

    if s'Last < i then
      arg := 0;
    else
      if not Is_Decimal_Digit (s (i)) and then s (i) /= '-' then
        i := i + 1;
      end if;
      j := i;
      while j <= s'Last
       and then (Is_Decimal_Digit (s (j)) or else s (j) = '-')
      loop
        j := j + 1;
      end loop;
      arg := string_to_vmint (s (i .. j - 1));
    end if;
  end parse_instruction;

  procedure read_and_parse_header
   (data_count    : out vmint;
    strings_count : out vmint)
  is
    line : Unbounded_String;
  begin
    Get_Line (Current_Input, line);
    parse_header (To_String (line), data_count, strings_count);
  end read_and_parse_header;

  procedure read_parse_and_store_strings
   (strings_count : in vmint)
  is
    line : Unbounded_String;
  begin
    if strings_count /= 0 then
      if strings_size < strings_count then
        raise vm_limit_exceeded with "strings limit exceeded";
      end if;
      for i in 0 .. strings_count - 1 loop
        Get_Line (Current_Input, line);
        strings (Integer (i)) :=
         parse_string_literal (To_String (line));
      end loop;
    end if;
  end read_parse_and_store_strings;

  function opcode_takes_arg
   (opcode : in byte)
    return Boolean
  is
    retval : Boolean;
  begin
    if opcode = op_fetch then
      retval := True;
    elsif opcode = op_store then
      retval := True;
    elsif opcode = op_push then
      retval := True;
    elsif opcode = op_jmp then
      retval := True;
    elsif opcode = op_jz then
      retval := True;
    else
      retval := False;
    end if;
    return retval;
  end opcode_takes_arg;

  procedure read_parse_and_store_instructions
  is
    line    : Unbounded_String;
    address : vmint;
    opcode  : byte;
    arg     : vmint;
    j       : Positive;
  begin
    while not End_Of_File (Current_Input) loop
      Get_Line (Current_Input, line);

      j := 1;
      while j <= Length (line) and then Is_Space (Element (line, j))
      loop
        j := j + 1;
      end loop;

      if j <= Length (line) then
        parse_instruction (To_String (line), address, opcode, arg);
        if opcode_takes_arg (opcode) then
          if code_size - 4 <= address then
            raise vm_limit_exceeded with "code space limit exceeded";
          end if;
          code (Integer (address)) := opcode;
          --
          -- Little-endian storage.
          --
          code (Integer (address) + 1) := byte (arg and 16#FF#);
          code (Integer (address) + 2) :=
           byte ((arg / 16#100#) and 16#FF#);
          code (Integer (address) + 3) :=
           byte ((arg / 16#1_0000#) and 16#FF#);
          code (Integer (address) + 4) :=
           byte ((arg / 16#100_0000#) and 16#FF#);
        else
          if code_size <= address then
            raise vm_limit_exceeded with "code space limit exceeded";
          end if;
          code (Integer (address)) := opcode;
        end if;
      end if;
    end loop;
  end read_parse_and_store_instructions;

  procedure read_parse_and_store_program
  is
    data_count    : vmint;
    strings_count : vmint;
  begin
    read_and_parse_header (data_count, strings_count);
    read_parse_and_store_strings (strings_count);
    read_parse_and_store_instructions;
  end read_parse_and_store_program;

  procedure pop_value
   (x : out vmint)
  is
  begin
    if sp = 0 then
      raise vm_runtime_error with "stack underflow";
    end if;
    sp := sp - 1;
    x  := stack (Integer (sp));
  end pop_value;

  procedure push_value
   (x : in vmint)
  is
  begin
    if stack_size <= sp then
      raise vm_runtime_error with "stack overflow";
    end if;
    stack (Integer (sp)) := x;
    sp                   := sp + 1;
  end push_value;

  procedure get_value
   (x : out vmint)
  is
  begin
    if sp = 0 then
      raise vm_runtime_error with "stack underflow";
    end if;
    x := stack (Integer (sp) - 1);
  end get_value;

  procedure put_value
   (x : in vmint)
  is
  begin
    if sp = 0 then
      raise vm_runtime_error with "stack underflow";
    end if;
    stack (Integer (sp) - 1) := x;
  end put_value;

  procedure fetch_value
   (i : in     vmint;
    x :    out vmint)
  is
  begin
    if data_size <= i then
      raise vm_runtime_error with "data boundary exceeded";
    end if;
    x := data (Integer (i));
  end fetch_value;

  procedure store_value
   (i : in vmint;
    x : in vmint)
  is
  begin
    if data_size <= i then
      raise vm_runtime_error with "data boundary exceeded";
    end if;
    data (Integer (i)) := x;
  end store_value;

  procedure immediate_value
   (x : out vmint)
  is
    b0, b1, b2, b3 : vmint;
  begin
    if code_size - 4 <= pc then
      raise vm_runtime_error with "code boundary exceeded";
    end if;
    --
    -- Little-endian order.
    --
    b0 := vmint (code (Integer (pc)));
    b1 := vmint (code (Integer (pc) + 1));
    b2 := vmint (code (Integer (pc) + 2));
    b3 := vmint (code (Integer (pc) + 3));
    x  :=
     b0 + (16#100# * b1) + (16#1_0000# * b2) + (16#100_0000# * b3);
  end immediate_value;

  procedure machine_add
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value (x + y);
  end machine_add;

  procedure machine_sub
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value (x - y);
  end machine_sub;

  procedure machine_mul
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value
     (vmsigned_to_vmint
       (vmint_to_vmsigned (x) * vmint_to_vmsigned (y)));
  end machine_mul;

  procedure machine_div
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value
     (vmsigned_to_vmint
       (vmint_to_vmsigned (x) / vmint_to_vmsigned (y)));
  end machine_div;

  procedure machine_mod
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    put_value
     (vmsigned_to_vmint
       (vmint_to_vmsigned (x) rem vmint_to_vmsigned (y)));
  end machine_mod;

  procedure machine_lt
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if vmint_to_vmsigned (x) < vmint_to_vmsigned (y) then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_lt;

  procedure machine_gt
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if vmint_to_vmsigned (x) > vmint_to_vmsigned (y) then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_gt;

  procedure machine_le
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if vmint_to_vmsigned (x) <= vmint_to_vmsigned (y) then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_le;

  procedure machine_ge
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if vmint_to_vmsigned (x) >= vmint_to_vmsigned (y) then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_ge;

  procedure machine_eq
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if x = y then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_eq;

  procedure machine_ne
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if x /= y then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_ne;

  procedure machine_and
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if x /= 0 and y /= 0 then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_and;

  procedure machine_or
  is
    x, y : vmint;
  begin
    pop_value (y);
    get_value (x);
    if x /= 0 or y /= 0 then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_or;

  procedure machine_neg
  is
    x : vmint;
  begin
    get_value (x);
    put_value (twos_complement (x));
  end machine_neg;

  procedure machine_not
  is
    x : vmint;
  begin
    get_value (x);
    if x = 0 then
      put_value (1);
    else
      put_value (0);
    end if;
  end machine_not;

  procedure machine_prtc
  is
    x : vmint;
  begin
    pop_value (x);
    Character'Write (output_stream, Character'Val (x));
  end machine_prtc;

  procedure machine_prti
  is
    x : vmint;
  begin
    pop_value (x);
    if 16#7FFF_FFFF# < x then
      Character'Write (output_stream, '-');
      String'Write
       (output_stream,
        To_String (vmint_to_digits (twos_complement (x))));
    else
      String'Write (output_stream, To_String (vmint_to_digits (x)));
    end if;
  end machine_prti;

  procedure machine_prts
  is
    k : vmint;
  begin
    pop_value (k);
    if strings_size <= k then
      raise vm_runtime_error with "strings boundary exceeded";
    end if;
    String'Write (output_stream, To_String (strings (Integer (k))));
  end machine_prts;

  procedure machine_fetch
  is
    k : vmint;
    x : vmint;
  begin
    immediate_value (k);
    fetch_value (k, x);
    push_value (x);
    pc := pc + 4;
  end machine_fetch;

  procedure machine_store
  is
    k : vmint;
    x : vmint;
  begin
    immediate_value (k);
    pop_value (x);
    store_value (k, x);
    pc := pc + 4;
  end machine_store;

  procedure machine_push
  is
    x : vmint;
  begin
    immediate_value (x);
    push_value (x);
    pc := pc + 4;
  end machine_push;

  procedure machine_jmp
  is
    offset : vmint;
  begin
    immediate_value (offset);
    pc := pc + offset;
  end machine_jmp;

  procedure machine_jz
  is
    x      : vmint;
    offset : vmint;
  begin
    pop_value (x);
    if x = 0 then
      immediate_value (offset);
      pc := pc + offset;
    else
      pc := pc + 4;
    end if;
  end machine_jz;

  procedure machine_step
   (halt : out Boolean)
  is
    opcode             : byte;
    op_div_4, op_rem_4 : byte;
  begin
    if code_size <= pc then
      raise vm_runtime_error with "code boundary exceeded";
    end if;
    opcode   := code (Integer (pc));
    pc       := pc + 1;
    halt     := False;
    op_div_4 := opcode / 4;
    op_rem_4 := opcode rem 4;
    if op_div_4 = 0 then
      if op_rem_4 = 0 then
        halt := True;
      elsif op_rem_4 = 1 then
        machine_add;
      elsif op_rem_4 = 2 then
        machine_sub;
      else
        machine_mul;
      end if;
    elsif op_div_4 = 1 then
      if op_rem_4 = 0 then
        machine_div;
      elsif op_rem_4 = 1 then
        machine_mod;
      elsif op_rem_4 = 2 then
        machine_lt;
      else
        machine_gt;
      end if;
    elsif op_div_4 = 2 then
      if op_rem_4 = 0 then
        machine_le;
      elsif op_rem_4 = 1 then
        machine_ge;
      elsif op_rem_4 = 2 then
        machine_eq;
      else
        machine_ne;
      end if;
    elsif op_div_4 = 3 then
      if op_rem_4 = 0 then
        machine_and;
      elsif op_rem_4 = 1 then
        machine_or;
      elsif op_rem_4 = 2 then
        machine_neg;
      else
        machine_not;
      end if;
    elsif op_div_4 = 4 then
      if op_rem_4 = 0 then
        machine_prtc;
      elsif op_rem_4 = 1 then
        machine_prti;
      elsif op_rem_4 = 2 then
        machine_prts;
      else
        machine_fetch;
      end if;
    elsif op_div_4 = 5 then
      if op_rem_4 = 0 then
        machine_store;
      elsif op_rem_4 = 1 then
        machine_push;
      elsif op_rem_4 = 2 then
        machine_jmp;
      else
        machine_jz;
      end if;
    else
      -- Treat anything unrecognized as equivalent to a halt.
      halt := True;
    end if;
  end machine_step;

  procedure machine_continue
  is
    halt : Boolean;
  begin
    halt := False;
    while not halt loop
      machine_step (halt);
    end loop;
  end machine_continue;

  procedure machine_run
  is
  begin
    sp := 0;
    pc := 0;
    for i in data'Range loop
      data (i) := 0;
    end loop;
    machine_continue;
  end machine_run;

begin
  status := 0;

  input_file_name := To_Unbounded_String ("-");

  if Argument_Count = 0 then
    null;
  elsif Argument_Count = 1 then
    input_file_name := To_Unbounded_String (Argument (1));
  else
    Put ("Usage: ");
    Put (Command_Name);
    Put_Line (" [INPUTFILE]");
    Put ("If either INPUTFILE is missing or ""-"",");
    Put_Line (" standard input is used.");
    Put_Line ("Output is always to standard output.");
    status := 1;
  end if;

  if status = 0 then
    if input_file_name /= "-" then
      Open (input_file, In_File, To_String (input_file_name));
      Set_Input (input_file);
    end if;

    output_stream := Stream (Current_Output);
    read_parse_and_store_program;
    machine_run;

    if input_file_name /= "-" then
      Set_Input (Standard_Input);
      Close (input_file);
    end if;
  end if;

  Set_Exit_Status (status);
end VM;


integer n, pc, sp;
file f;
text s;
index code, Data;
list l, stack, strings;

f.affix(argv(1));

f.list(l, 0);

n = atoi(l[-1]);
while (n) {
    f.lead(s);
    strings.append(erase(s, -1, 0));
    n -= 1;
}

while (f.list(l, 0) ^ -1) {
    code.put(atoi(lf_x_text(l)), l);
}

pc = sp = 0;
while (1) {
    l = code[pc];
    s = l[0];
    if (s == "jz") {
        if (lb_pick(stack)) {
            isk_greater(code, pc, pc);
        } else {
            pc = atoi(l[-1]);
        }
    } elif (s == "jmp") {
        pc = atoi(l[-1]);
    } else {
        if (s == "push") {
            lb_push(stack, atoi(l[1]));
        } elif (s == "fetch") {
            lb_push(stack, Data[atoi(erase(l[1], -1, 0))]);
        } elif (s == "neg") {
            stack[-1] = -stack[-1];
        } elif (s == "not") {
            stack[-1] = !stack[-1];
        } elif (s == "halt") {
            break;
        } else {
            n = lb_pick(stack);
            if (s == "store") {
                Data[atoi(erase(l[1], -1, 0))] = n;
            } elif (s == "add") {
                stack[-1] = stack[-1] + n;
            } elif (s == "sub") {
                stack[-1] = stack[-1] - n;
            } elif (s == "mul") {
                stack[-1] = stack[-1] * n;
            } elif (s == "div") {
                stack[-1] = stack[-1] / n;
            } elif (s == "mod") {
                stack[-1] = stack[-1] % n;
            } elif (s == "lt") {
                stack[-1] = stack[-1] < n;
            } elif (s == "gt") {
                stack[-1] = stack[-1] > n;
            } elif (s == "le") {
                stack[-1] = stack[-1] <= n;
            } elif (s == "ge") {
                stack[-1] = stack[-1] >= n;
            } elif (s == "eq") {
                stack[-1] = stack[-1] == n;
            } elif (s == "ne") {
                stack[-1] = stack[-1] != n;
            } elif (s == "and") {
                stack[-1] = stack[-1] && n;
            } elif (s == "or") {
                stack[-1] = stack[-1] || n;
            } elif (s == "prtc") {
                o_byte(n);
            } elif (s == "prti") {
                o_(n);
            } elif (s == "prts") {
                o_(strings[n]);
            } else {
            }
        }

        isk_greater(code, pc, pc);
    }
}