#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "[email protected]"
|#
(progn ;;init forms
  (ros:ensure-asdf)
  #+quicklisp(ql:quickload '() :silent t)
  )

(defpackage :ros.script.vm.3858678051
  (:use :cl))
(in-package :ros.script.vm.3858678051)

;;;
;;; The Rosetta Code Virtual Machine, in Common Lisp.
;;;
;;; Notes:
;;;
;;;   * I have tried not to use foreign types or similar means of
;;;     optimization.
;;;
;;;   * Integers are stored in the VM's executable memory in
;;;     big-endian order. Not because I prefer it, but because I do
;;;     not want to get myself into a little-endian rut.
;;;

(require "cl-ppcre")
(require "trivia")

;;; Yes, I could compute how much memory is needed, or I could assume
;;; that the instructions are in address order. However, for *this*
;;; implementation I am going to use a large fixed-size memory and use
;;; the address fields of instructions to place the instructions.
(defconstant executable-memory-size 65536
  "The size of memory for executable code, in 8-bit words.")

;;; Similarly, I am going to have fixed size data and stack memory.
(defconstant data-memory-size 2048
  "The size of memory for stored data, in 32-bit words.")
(defconstant stack-memory-size 2048
  "The size of memory for the stack, in 32-bit words.")

;;; And so I am going to have specialized types for the different
;;; kinds of memory the platform contains. Also for its "word" and
;;; register types.
(deftype word ()
  '(unsigned-byte 32))
(deftype register ()
  '(simple-array word (1)))
(deftype executable-memory ()
  `(simple-array (unsigned-byte 8) ,(list executable-memory-size)))
(deftype data-memory ()
  `(simple-array word ,(list data-memory-size)))
(deftype stack-memory ()
  `(simple-array word ,(list stack-memory-size)))

(defconstant re-blank-line
  (ppcre:create-scanner "^\\s*$"))

(defconstant re-parse-instr-1
  (ppcre:create-scanner "^\\s*(\\d+)\\s*(.*\\S)"))

(defconstant re-parse-instr-2
  (ppcre:create-scanner "(?i)^(\\S+)\\s*(.*)"))

(defconstant re-parse-instr-3
  (ppcre:create-scanner "^[[(]?([0-9-]+)"))

(defconstant opcode-names
  #("halt"
    "add"
    "sub"
    "mul"
    "div"
    "mod"
    "lt"
    "gt"
    "le"
    "ge"
    "eq"
    "ne"
    "and"
    "or"
    "neg"
    "not"
    "prtc"
    "prti"
    "prts"
    "fetch"
    "store"
    "push"
    "jmp"
    "jz"))

(defun blank-line-p (s)
  (not (not (ppcre:scan re-blank-line s))))

(defun opcode-from-name (s)
  (position-if (lambda (name)
                 (string= s name))
               opcode-names))

(defun create-executable-memory ()
  (coerce (make-list executable-memory-size
                     :initial-element (opcode-from-name "halt"))
          'executable-memory))

(defun create-data-memory ()
  (coerce (make-list data-memory-size :initial-element 0)
          'data-memory))

(defun create-stack-memory ()
  (coerce (make-list stack-memory-size :initial-element 0)
          'stack-memory))

(defun create-register ()
  (coerce (make-list 1 :initial-element 0) 'register))

(defstruct machine
  (sp (create-register) :type register) ; Stack pointer.
  (ip (create-register) :type register) ; Instruction pointer (same
  ; thing as program counter).
  (code (create-executable-memory) :type executable-memory)
  (data (create-data-memory) :type data-memory)
  (stack (create-stack-memory) :type stack-memory)
  (strings nil)
  output *standard-output*)

(defun insert-instruction (memory instr)
  (declare (type executable-memory memory))
  (trivia:match instr
    ((list address opcode arg)
     (let ((instr-size (if arg 5 1)))
       (unless (<= (+ address instr-size) executable-memory-size)
         (warn "the VM's executable memory size is exceeded")
         (uiop:quit 1))
       (setf (elt memory address) opcode)
       (when arg
         ;; Big-endian order.
         (setf (elt memory (+ address 1)) (ldb (byte 8 24) arg))
         (setf (elt memory (+ address 2)) (ldb (byte 8 16) arg))
         (setf (elt memory (+ address 3)) (ldb (byte 8 8) arg))
         (setf (elt memory (+ address 4)) (ldb (byte 8 0) arg)))))))

(defun load-executable-memory (memory instr-lst)
  (declare (type executable-memory memory))
  (loop for instr in instr-lst
        do (insert-instruction memory instr)))

(defun parse-instruction (s)
  (if (blank-line-p s)
      nil
      (let* ((strings (nth-value 1 (ppcre:scan-to-strings
                                    re-parse-instr-1 s)))
             (address (parse-integer (elt strings 0)))
             (split (nth-value 1 (ppcre:scan-to-strings
                                  re-parse-instr-2 (elt strings 1))))
             (opcode-name (string-downcase (elt split 0)))
             (opcode (opcode-from-name opcode-name))
             (arguments (elt split 1))
             (has-arg (trivia:match opcode-name
                        ((or "fetch" "store" "push" "jmp" "jz") t)
                        (_ nil))))
        (if has-arg
            (let* ((argstr-lst
                     (nth-value 1 (ppcre:scan-to-strings
                                   re-parse-instr-3 arguments)))
                   (argstr (elt argstr-lst 0)))
              `(,address ,opcode ,(parse-integer argstr)))
            `(,address ,opcode ())))))

(defun read-instructions (inpf)
  (loop for line = (read-line inpf nil 'eoi)
        until (eq line 'eoi)
        for instr = (parse-instruction line)
        when instr collect instr))

(defun read-datasize-and-strings-count (inpf)
  (let ((line (read-line inpf)))
    (multiple-value-bind (_whole-match strings)
        ;; This is a permissive implementation.
        (ppcre:scan-to-strings
         "(?i)^\\s*Datasize\\s*:\\s*(\\d+)\\s*Strings\\s*:\\s*(\\d+)"
         line)
      (declare (ignore _whole-match))
      `(,(parse-integer (elt strings 0))
        ,(parse-integer (elt strings 1))))))

(defun parse-string-literal (s)
  ;; This is a permissive implementation, but only in that it skips
  ;; any leading space. It does not check carefully for outright
  ;; mistakes.
  (let* ((s (ppcre:regex-replace "^\\s*" s ""))
         (quote-mark (elt s 0))
         (i 1)
         (lst
           (loop until (char= (elt s i) quote-mark)
                 collect (let ((c (elt s i)))
                           (if (char= c #\\)
                               (let ((c0 (trivia:match (elt s (1+ i))
                                           (#\n #\newline)
                                           (c1 c1))))
                                 (setq i (+ i 2))
                                 c0)
                               (progn
                                 (setq i (1+ i))
                                 c))))))
    (coerce lst 'string)))

(defun read-string-literals (inpf strings-count)
  (loop for i from 1 to strings-count
        collect (parse-string-literal (read-line inpf))))

(defun open-inpf (inpf-filename)
  (if (string= inpf-filename "-")
      *standard-input*
      (open inpf-filename :direction :input)))

(defun open-outf (outf-filename)
  (if (string= outf-filename "-")
      *standard-output*
      (open outf-filename :direction :output
                          :if-exists :overwrite
                          :if-does-not-exist :create)))

(defun word-signbit-p (x)
  "True if and only if the sign bit is set."
  (declare (type word x))
  (/= 0 (logand x #x80000000)))

(defun word-add (x y)
  "Addition with overflow freely allowed."
  (declare (type word x))
  (declare (type word y))
  (coerce (logand (+ x y) #xFFFFFFFF) 'word))

(defun word-neg (x)
  "The two's complement."
  (declare (type word x))
  (word-add (logxor x #xFFFFFFFF) 1))

(defun word-sub (x y)
  "Subtraction with overflow freely allowed."
  (declare (type word x))
  (declare (type word y))
  (word-add x (word-neg y)))

(defun word-mul (x y)
  "Signed multiplication."
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-xy (the word
                          (logand (* abs-x abs-y) #xFFFFFFFF))))
        (if x<0
            (if y<0 abs-xy (word-neg abs-xy))
            (if y<0 (word-neg abs-xy) abs-xy))))))

(defun word-div (x y)
  "The quotient after signed integer division with truncation towards
zero."
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x/y (the word
                           (logand (floor abs-x abs-y) #xFFFFFFFF))))
        (if x<0
            (if y<0 abs-x/y (word-neg abs-x/y))
            (if y<0 (word-neg abs-x/y) abs-x/y))))))

(defun word-mod (x y)
  "The remainder after signed integer division with truncation towards
zero."
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (let ((abs-x (if x<0 (word-neg x) x))
          (abs-y (if y<0 (word-neg y) y)))
      (let* ((abs-x%y (the word
                           (logand (nth-value 1 (floor abs-x abs-y))
                                   #xFFFFFFFF))))
        (if x<0 (word-neg abs-x%y) abs-x%y)))))

(defun b2i (b)
  (declare (type boolean b))
  (if b 1 0))

(defun word-lt (x y)
  "Signed comparison: is x less than y?"
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (b2i (if x<0
             (if y<0 (< x y) t)
             (if y<0 nil (< x y))))))

(defun word-le (x y)
  "Signed comparison: is x less than or equal to y?"
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (b2i (if x<0
             (if y<0 (<= x y) t)
             (if y<0 nil (<= x y))))))

(defun word-gt (x y)
  "Signed comparison: is x greater than y?"
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (b2i (if x<0
             (if y<0 (> x y) nil)
             (if y<0 t (> x y))))))

(defun word-ge (x y)
  "Signed comparison: is x greater than or equal to y?"
  (declare (type word x))
  (declare (type word y))
  (let ((x<0 (word-signbit-p x))
        (y<0 (word-signbit-p y)))
    (b2i (if x<0
             (if y<0 (>= x y) nil)
             (if y<0 t (>= x y))))))

(defun word-eq (x y)
  "Is x equal to y?"
  (declare (type word x))
  (declare (type word y))
  (b2i (= x y)))

(defun word-ne (x y)
  "Is x not equal to y?"
  (declare (type word x))
  (declare (type word y))
  (b2i (/= x y)))

(defun word-cmp (x)
  "The logical complement."
  (declare (type word x))
  (b2i (= x 0)))

(defun word-and (x y)
  "The logical conjunction."
  (declare (type word x))
  (declare (type word y))
  (b2i (and (/= x 0) (/= y 0))))

(defun word-or (x y)
  "The logical disjunction."
  (declare (type word x))
  (declare (type word y))
  (b2i (or (/= x 0) (/= y 0))))

(defun unop (stack sp operation)
  "Perform a unary operation on the stack."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type (function (word) word) operation))
  (let ((i (elt sp 0)))
    (unless (<= 1 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let ((x (elt stack (1- i))))
      (setf (elt stack (1- i)) (funcall operation x)))))

(defun binop (stack sp operation)
  "Perform a binary operation on the stack."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type (function (word word) word) operation))
  (let ((i (elt sp 0)))
    (unless (<= 2 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let ((x (elt stack (- i 2)))
          (y (elt stack (1- i))))
      (setf (elt stack (- i 2)) (funcall operation x y)))
    (setf (elt sp 0) (1- i))))

(defun jri (code ip)
  "Jump relative immediate."
  (declare (type executable-memory code))
  (declare (type register ip))
  ;; Big-endian order.
  (let ((j (elt ip 0)))
    (unless (<= (+ j 4) executable-memory-size)
      (warn "address past end of executable memory")
      (uiop:quit 1))
    (let* ((offset (elt code (+ j 3)))
           (offset (dpb (elt code (+ j 2)) (byte 8 8) offset))
           (offset (dpb (elt code (+ j 1)) (byte 8 16) offset))
           (offset (dpb (elt code j) (byte 8 24) offset)))
      (setf (elt ip 0) (word-add j offset)))))

(defun jriz (stack sp code ip)
  "Jump relative immediate, if zero."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type executable-memory code))
  (declare (type register ip))
  (let ((i (elt sp 0)))
    (unless (<= 1 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let ((x (elt stack (1- i))))
      (setf (elt sp 0) (1- i))
      (if (= x 0)
          (jri code ip)
          (setf (elt ip 0) (+ (elt ip 0) 4))))))

(defun get-immediate-value (code ip)
  (declare (type executable-memory code))
  (declare (type register ip))
  ;; Big-endian order.
  (let ((j (elt ip 0)))
    (unless (<= (+ j 4) executable-memory-size)
      (warn "address past end of executable memory")
      (uiop:quit 1))
    (let* ((x (elt code (+ j 3)))
           (x (dpb (elt code (+ j 2)) (byte 8 8) x))
           (x (dpb (elt code (+ j 1)) (byte 8 16) x))
           (x (dpb (elt code j) (byte 8 24) x)))
      (setf (elt ip 0) (+ j 4))
      x)))

(defun pushi (stack sp code ip)
  "Push-immediate a value from executable memory onto the stack."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type executable-memory code))
  (declare (type register ip))
  (let ((i (elt sp 0)))
    (unless (< i stack-memory-size)
      (warn "stack overflow")
      (uiop:quit 1))
    (setf (elt stack i) (get-immediate-value code ip))
    (setf (elt sp 0) (1+ i))))

(defun fetch (stack sp code ip data)
  "Fetch data to the stack, using the storage location given in
executable memory."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type executable-memory code))
  (declare (type register ip))
  (declare (type data-memory data))
  (let ((i (elt sp 0)))
    (unless (< i stack-memory-size)
      (warn "stack overflow")
      (uiop:quit 1))
    (let* ((k (get-immediate-value code ip))
           (x (elt data k)))
      (setf (elt stack i) x)
      (setf (elt sp 0) (1+ i)))))

(defun pop-one (stack sp)
  (let ((i (elt sp 0)))
    (unless (<= 1 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let* ((x (elt stack (1- i))))
      (setf (elt sp 0) (1- i))
      x)))

(defun store (stack sp code ip data)
  "Store data from the stack, using the storage location given in
executable memory."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (declare (type executable-memory code))
  (declare (type register ip))
  (declare (type data-memory data))
  (let ((i (elt sp 0)))
    (unless (<= 1 i)
      (warn "stack underflow")
      (uiop:quit 1))
    (let ((k (get-immediate-value code ip))
          (x (pop-one stack sp)))
      (setf (elt data k) x))))

(defun prti (stack sp outf)
  "Print the top value of the stack, as a signed decimal value."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (let* ((n (pop-one stack sp))
         (n<0 (word-signbit-p n)))
    (if n<0
        (format outf "-~D" (word-neg n))
        (format outf "~D" n))))

(defun prtc (stack sp outf)
  "Print the top value of the stack, as a character."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (let* ((c (pop-one stack sp)))
    (format outf "~C" (code-char c))))

(defun prts (stack sp strings outf)
  "Print the string specified by the top of the stack."
  (declare (type stack-memory stack))
  (declare (type register sp))
  (let* ((k (pop-one stack sp))
         (s (elt strings k)))
    (format outf "~A" s)))

(defmacro defun-machine-binop (op)
  (let ((machine-op (read-from-string
                     (concatenate 'string "machine-" (string op))))
        (word-op (read-from-string
                  (concatenate 'string "word-" (string op)))))
    `(defun ,machine-op (mach)
       (declare (type machine mach))
       (binop (machine-stack mach)
              (machine-sp mach)
              #',word-op))))

(defmacro defun-machine-unop (op)
  (let ((machine-op (read-from-string
                     (concatenate 'string "machine-" (string op))))
        (word-op (read-from-string
                  (concatenate 'string "word-" (string op)))))
    `(defun ,machine-op (mach)
       (declare (type machine mach))
       (unop (machine-stack mach)
             (machine-sp mach)
             #',word-op))))

(defun-machine-binop "add")
(defun-machine-binop "sub")
(defun-machine-binop "mul")
(defun-machine-binop "div")
(defun-machine-binop "mod")
(defun-machine-binop "lt")
(defun-machine-binop "gt")
(defun-machine-binop "le")
(defun-machine-binop "ge")
(defun-machine-binop "eq")
(defun-machine-binop "ne")
(defun-machine-binop "and")
(defun-machine-binop "or")

(defun-machine-unop "neg")
(defun machine-not (mach)
  (declare (type machine mach))
  (unop (machine-stack mach)
        (machine-sp mach)
        #'word-cmp))

(defun machine-prtc (mach)
  (declare (type machine mach))
  (prtc (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))

(defun machine-prti (mach)
  (declare (type machine mach))
  (prti (machine-stack mach)
        (machine-sp mach)
        (machine-output mach)))

(defun machine-prts (mach)
  (declare (type machine mach))
  (prts (machine-stack mach)
        (machine-sp mach)
        (machine-strings mach)
        (machine-output mach)))

(defun machine-fetch (mach)
  (declare (type machine mach))
  (fetch (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))

(defun machine-store (mach)
  (declare (type machine mach))
  (store (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)
         (machine-data mach)))

(defun machine-push (mach)
  (declare (type machine mach))
  (pushi (machine-stack mach)
         (machine-sp mach)
         (machine-code mach)
         (machine-ip mach)))

(defun machine-jmp (mach)
  (declare (type machine mach))
  (jri (machine-code mach)
       (machine-ip mach)))

(defun machine-jz (mach)
  (declare (type machine mach))
  (jriz (machine-stack mach)
        (machine-sp mach)
        (machine-code mach)
        (machine-ip mach)))

(defun get-opcode (mach)
  (declare (type machine mach))
  (let ((code (machine-code mach))
        (ip (machine-ip mach)))
    (let ((j (elt ip 0)))
      (unless (< j executable-memory-size)
        (warn "address past end of executable memory")
        (uiop:quit 1))
      (let ((opcode (elt code j)))
        (setf (elt ip 0) (1+ j))
        opcode))))

(defun run-instruction (mach opcode)
  (declare (type machine mach))
  (declare (type fixnum opcode))
  (let ((op-mod-4 (logand opcode #x3))
        (op-div-4 (ash opcode -2)))
    (trivia:match op-div-4
      (0 (trivia:match op-mod-4
           (1 (machine-add mach))
           (2 (machine-sub mach))
           (3 (machine-mul mach))))
      (1 (trivia:match op-mod-4
           (0 (machine-div mach))
           (1 (machine-mod mach))
           (2 (machine-lt mach))
           (3 (machine-gt mach))))
      (2 (trivia:match op-mod-4
           (0 (machine-le mach))
           (1 (machine-ge mach))
           (2 (machine-eq mach))
           (3 (machine-ne mach))))
      (3 (trivia:match op-mod-4
           (0 (machine-and mach))
           (1 (machine-or mach))
           (2 (machine-neg mach))
           (3 (machine-not mach))))
      (4 (trivia:match op-mod-4
           (0 (machine-prtc mach))
           (1 (machine-prti mach))
           (2 (machine-prts mach))
           (3 (machine-fetch mach))))
      (5 (trivia:match op-mod-4
           (0 (machine-store mach))
           (1 (machine-push mach))
           (2 (machine-jmp mach))
           (3 (machine-jz mach)))))))

(defun run-vm (mach)
  (declare (type machine mach))
  (let ((opcode-for-halt (the fixnum (opcode-from-name "halt")))
        (opcode-for-add (the fixnum (opcode-from-name "add")))
        (opcode-for-jz (the fixnum (opcode-from-name "jz"))))
    (loop for opcode = (the fixnum (get-opcode mach))
          until (= opcode opcode-for-halt)
          do (progn (when (or (< opcode opcode-for-add)
                              (< opcode-for-jz opcode))
                      (warn "unsupported opcode")
                      (uiop:quit 1))
                    (run-instruction mach opcode)))))

(defun usage-error ()
  (princ "Usage: vm [INPUTFILE [OUTPUTFILE]]" *standard-output*)
  (terpri *standard-output*)
  (princ "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
         *standard-output*)
  (princ " standard I/O is used." *standard-output*)
  (terpri *standard-output*)
  (uiop:quit 1))

(defun get-filenames (argv)
  (trivia:match argv
    ((list) '("-" "-"))
    ((list inpf-filename) `(,inpf-filename "-"))
    ((list inpf-filename outf-filename) `(,inpf-filename
                                          ,outf-filename))
    (_ (usage-error))))

(defun main (&rest argv)
  (let* ((filenames (get-filenames argv))
         (inpf-filename (car filenames))
         (inpf (open-inpf inpf-filename))
         (outf-filename (cadr filenames))
         (outf (open-outf outf-filename))

         (sizes (read-datasize-and-strings-count inpf))
         (datasize (car sizes))
         (strings-count (cadr sizes))
         (strings (read-string-literals inpf strings-count))
         (instructions (read-instructions inpf))
         ;; We shall remain noncommittal about how strings are stored
         ;; on the hypothetical machine.
         (strings (coerce strings 'simple-vector))

         (mach (make-machine :strings strings
                             :output outf)))

    (unless (<= datasize data-memory-size)
      (warn "the VM's data memory size is exceeded")
      (uiop:quit 1))

    (load-executable-memory (machine-code mach) instructions)
    (run-vm mach)

    (unless (string= inpf-filename "-")
      (close inpf))
    (unless (string= outf-filename "-")
      (close outf))

    (uiop:quit 0)))

;;; vim: set ft=lisp lisp:


      HIMEM = PAGE + 2000000
      INSTALL @lib$+"SORTLIB"
      INSTALL @lib$+"TIMERLIB"
      Sort% = FN_sortinit(0,0)
      Timer% = FN_ontimer(1000, PROCtimer, 1)

      PRINT "Array size:", 1000, 10000, 100000
      @% = &2020A

      FOR patt% = 1 TO 4
        CASE patt% OF
          WHEN 1: PRINT '"Data set to all ones:"
          WHEN 2: PRINT '"Data ascending sequence:"
          WHEN 3: PRINT '"Data randomly shuffled:"
          WHEN 4: PRINT '"Data descending sequence:"
        ENDCASE

        FOR type% = 1 TO 6
          CASE type% OF
            WHEN 1: PRINT "Internal (lib)";
            WHEN 2: PRINT "Quicksort   ";
            WHEN 3: PRINT "Radix sort  ";
            WHEN 4: PRINT "Shellsort   ";
            WHEN 5: PRINT "Bubblesort  ";
            WHEN 6: PRINT "Insertion sort";
          ENDCASE

          FOR power% = 3 TO 5
            PROCsorttest(patt%, type%, 10^power%)
          NEXT
          PRINT

        NEXT type%
      NEXT patt%
      END

      DEF PROCsorttest(patt%, type%, size%)
      LOCAL a%(), C%, I%
      DIM a%(size%-1)

      CASE patt% OF
        WHEN 1: a%() = 1 : a%() = 1
        WHEN 2: FOR I% = 0 TO size%-1 : a%(I%) = I% : NEXT
        WHEN 3: FOR I% = 0 TO size%-1 : a%(I%) = I% : NEXT
          C% = RND(-123456) : REM Seed
          FOR I% = size% TO 2 STEP -1 : SWAP a%(I%-1),a%(RND(I%)-1) : NEXT
        WHEN 4: FOR I% = 0 TO size%-1 : a%(I%) = size%-1-I% : NEXT
      ENDCASE

      Start% = TIME
      ON ERROR LOCAL PRINT , "   >100.00" ; : ENDPROC
      CASE type% OF
        WHEN 1: C% = size% : CALL Sort%, a%(0)
        WHEN 2: PROCquicksort(a%(), 0, size%)
        WHEN 3: PROCradixsort(a%(), size%, 10)
        WHEN 4: PROCshellsort(a%(), size%)
        WHEN 5: PROCbubblesort(a%(), size%)
        WHEN 6: PROCinsertionsort(a%(), size%)
      ENDCASE
      PRINT , (TIME - Start%)/100;

      FOR I% = 0 TO size%-2
        IF a%(I%) > a%(I%+1) ERROR 100, "Sort failed!"
      NEXT
      ENDPROC

      DEF PROCtimer
      Start% += 0
      IF (TIME - Start%) > 10000 ERROR 111, ""
      ENDPROC

      DEF PROCbubblesort(a%(), n%)
      LOCAL i%, l%
      REPEAT
        l% = 0
        FOR i% = 1 TO n%-1
          IF a%(i%-1) > a%(i%) THEN
            SWAP a%(i%-1),a%(i%)
            l% = i%
          ENDIF
        NEXT
        n% = l%
      UNTIL l% = 0
      ENDPROC

      DEF PROCinsertionsort(a%(), n%)
      LOCAL i%, j%, t%
      FOR i% = 1 TO n%-1
        t% = a%(i%)
        j% = i%
        WHILE j%>0 AND t%<a%(ABS(j%-1))
          a%(j%) = a%(j%-1)
          j% -= 1
        ENDWHILE
        a%(j%) = t%
      NEXT
      ENDPROC

      DEF PROCquicksort(a%(), s%, n%)
      LOCAL l%, p%, r%, t%
      IF n% < 2 THEN ENDPROC
      t% = s% + n% - 1
      l% = s%
      r% = t%
      p% = a%((l% + r%) DIV 2)
      REPEAT
        WHILE a%(l%) < p% l% += 1 : ENDWHILE
        WHILE a%(r%) > p% r% -= 1 : ENDWHILE
        IF l% <= r% THEN
          SWAP a%(l%), a%(r%)
          l% += 1
          r% -= 1
        ENDIF
      UNTIL l% > r%
      IF s% < r% PROCquicksort(a%(), s%, r% - s% + 1)
      IF l% < t% PROCquicksort(a%(), l%, t% - l% + 1 )
      ENDPROC

      DEF PROCshellsort(a%(), n%)
      LOCAL h%, i%, j%, k%
      h% = n%
      WHILE h%
        IF h% = 2 h% = 1 ELSE h% DIV= 2.2
        FOR i% = h% TO n% - 1
          k% = a%(i%)
          j% = i%
          WHILE j% >= h% AND k% < a%(ABS(j% - h%))
            a%(j%) = a%(j% - h%)
            j% -= h%
          ENDWHILE
          a%(j%) = k%
        NEXT
      ENDWHILE
      ENDPROC

      DEF PROCradixsort(a%(), n%, r%)
      LOCAL d%, e%, i%, l%, m%, b%(), bucket%()
      DIM b%(DIM(a%(),1)), bucket%(r%-1)
      FOR i% = 0 TO n%-1
        IF a%(i%) < l% l% = a%(i%)
        IF a%(i%) > m% m% = a%(i%)
      NEXT
      a%() -= l%
      m% -= l%
      e% = 1
      WHILE m% DIV e%
        bucket%() = 0
        FOR i% = 0 TO n%-1
          bucket%(a%(i%) DIV e% MOD r%) += 1
        NEXT
        FOR i% = 1 TO r%-1
          bucket%(i%) += bucket%(i% - 1)
        NEXT
        FOR i% = n%-1 TO 0 STEP -1
          d% = a%(i%) DIV e% MOD r%
          bucket%(d%) -= 1
          b%(bucket%(d%)) = a%(i%)
        NEXT
        a%() = b%()
        e% *= r%
      ENDWHILE
      a%() += l%
      ENDPROC


#ifndef _CSEQUENCE_H
#define _CSEQUENCE_H
#include <stdlib.h>

void setfillconst(double c);
void fillwithconst(double *v, int n);
void fillwithrrange(double *v, int n);
void shuffledrange(double *v, int n);
#endif


import std.stdio, std.algorithm, std.container, std.datetime,
       std.random, std.typetuple;

immutable int[] allOnes, sortedData, randomData;

static this() { // Initialize global Arrays.
    immutable size_t arraySize = 10_000;

    allOnes = new int[arraySize];
    //allOnes[] = 1;
    foreach (ref d; allOnes)
        d = 1;

    sortedData = new int[arraySize];
    foreach (immutable i, ref d; sortedData)
        d = i;

    randomData = new int[arraySize];
    foreach (ref d; randomData)
        d = uniform(0, int.max);
}

// BubbleSort:

void bubbleSort(T)(T[] list) {
    for (int i = list.length - 1; i > 0; i--)
        for (int j = i -1; j >= 0; j--)
            if (list[i] < list[j])
                swap(list[i], list[j]);
}

void allOnesBubble() {
    auto data = allOnes.dup;
    data.bubbleSort;
    assert(data.isSorted);
}

void sortedBubble() {
    auto data = sortedData.dup;
    data.bubbleSort;
    assert(data.isSorted);
}

void randomBubble() {
    auto data = randomData.dup;
    data.bubbleSort;
    assert(data.isSorted);
}

// InsertionSort:

void insertionSort(T)(T[] list) {
    foreach (immutable i, currElem; list) {
        size_t j = i;
        for (; j > 0 && currElem < list[j - 1]; j--)
            list[j] = list[j - 1];
        list[j] = currElem;
    }
}

void allOnesInsertion() {
    auto data = allOnes.dup;
    data.insertionSort;
    assert(data.isSorted);
}

void sortedInsertion() {
    auto data = sortedData.dup;
    data.insertionSort;
    assert(data.isSorted);
}

void randomInsertion() {
    auto data = randomData.dup;
    data.insertionSort;
    assert(data.isSorted);
}

// HeapSort:

void heapSort(T)(T[] data) {
    auto h = data.heapify;
    while (!h.empty)
        h.removeFront;
}

void allOnesHeap() {
    auto data = allOnes.dup;
    data.heapSort;
    assert(data.isSorted);
}

void sortedHeap() {
    auto data = sortedData.dup;
    data.heapSort;
    assert(data.isSorted);
}

void randomHeap() {
    auto data = randomData.dup;
    data.heapSort;
    assert(data.isSorted);
}

// Built-in sort:

void allOnesBuiltIn() {
    auto data = allOnes.dup;
    data.sort!q{a < b};
    assert(data.isSorted);
}

void sortedBuiltIn() {
    auto data = sortedData.dup;
    data.sort!q{a < b};
    assert(data.isSorted);
}

void randomBuiltIn() {
    auto data = randomData.dup;
    data.sort!q{a < b};
    assert(data.isSorted);
}

static void show(in TickDuration[4u] r) {
    alias args = TypeTuple!("usecs", int);
    writefln("    Bubble Sort:    %10d", r[0].to!args);
    writefln("    Insertion Sort: %10d", r[1].to!args);
    writefln("    Heap Sort:      %10d", r[3].to!args);
    writefln("    Built-in Sort:  %10d", r[2].to!args);
}

void main() {
    enum nRuns = 100;
    writeln("Timings in microseconds:");

    writeln("  Testing against all ones:");
    nRuns.benchmark!(allOnesBubble, allOnesInsertion,
                     allOnesHeap, allOnesBuiltIn).show;

    writeln("\n  Testing against sorted data.");
    nRuns.benchmark!(sortedBubble, sortedInsertion,
                     sortedHeap, sortedBuiltIn).show;

    writeln("\n  Testing against random data.");
    nRuns.benchmark!(randomBubble, randomInsertion,
                     randomHeap, randomBuiltIn).show;
}


//
// The Rosetta Code Virtual Machine in D.
//
// This code was migrated from an implementation in ATS. I have tried
// to keep it possible to compare the two languages easily, although
// in some cases the demonstration of "low level" techniques in ATS
// (such as avoiding memory leaks that might require garbage
// collection), or the use of linked lists as intermediate storage, or
// other such matters, seemed inappropriate to duplicate in D
// programming.
//
// (For example: in ATS, using a fully built linked list to initialize
// an array solves typechecking issues that simply do not exist in D's
// type system.)
//

import std.ascii;
import std.conv;
import std.stdint;
import std.stdio;
import std.string;
import std.typecons;

enum Op {
  HALT    = 0x0000,  // 00000
  ADD     = 0x0001,  // 00001
  SUB     = 0x0002,  // 00010
  MUL     = 0x0003,  // 00011
  DIV     = 0x0004,  // 00100
  MOD     = 0x0005,  // 00101
  LT      = 0x0006,  // 00110
  GT      = 0x0007,  // 00111
  LE      = 0x0008,  // 01000
  GE      = 0x0009,  // 01001
  EQ      = 0x000A,  // 01010
  NE      = 0x000B,  // 01011
  AND     = 0x000C,  // 01100
  OR      = 0x000D,  // 01101
  NEG     = 0x000E,  // 01110
  NOT     = 0x000F,  // 01111
  PRTC    = 0x0010,  // 10000
  PRTI    = 0x0011,  // 10001
  PRTS    = 0x0012,  // 10010
  FETCH   = 0x0013,  // 10011
  STORE   = 0x0014,  // 10100
  PUSH    = 0x0015,  // 10101
  JMP     = 0x0016,  // 10110
  JZ      = 0x0017   // 10111
}

const string[] opcodeOrder =
  ["halt",  // 00000   bit pattern
   "add",   // 00001
   "sub",   // 00010
   "mul",   // 00011
   "div",   // 00100
   "mod",   // 00101
   "lt",    // 00110
   "gt",    // 00111
   "le",    // 01000
   "ge",    // 01001
   "eq",    // 01010
   "ne",    // 01011
   "and",   // 01100
   "or",    // 01101
   "neg",   // 01110
   "not",   // 01111
   "prtc",  // 10000
   "prti",  // 10001
   "prts",  // 10010
   "fetch", // 10011
   "store", // 10100
   "push",  // 10101
   "jmp",   // 10110
   "jz"];   // 10111

enum Register {
  PC = 0,
  SP = 1,
  MAX = SP
}

alias vmint = uint32_t;

class VM {
  string[] strings;
  ubyte[] code;
  vmint[] data;
  vmint[] stack;
  vmint[Register.MAX + 1] registers;
}

class BadVMException : Exception
{
  this(string msg, string file = __FILE__, size_t line = __LINE__)
  {
    super(msg, file, line);
  }
}

class VMRuntimeException : Exception
{
  this(string msg, string file = __FILE__, size_t line = __LINE__)
  {
    super(msg, file, line);
  }
}

vmint
twosComplement (vmint x)
{
  // This computes the negative of x, if x is regarded as signed.
  pragma(inline);
  return (~x) + vmint(1U);
}

vmint
add (vmint x, vmint y)
{
  // This works whether x or y is regarded as unsigned or signed.
  pragma(inline);
  return x + y;
}

vmint
sub (vmint x, vmint y)
{
  // This works whether x or y is regarded as unsigned or signed.
  pragma(inline);
  return x - y;
}

vmint
equality (vmint x, vmint y)
{
  pragma(inline);
  return vmint(x == y);
}

vmint
inequality (vmint x, vmint y)
{
  pragma(inline);
  return vmint(x != y);
}

vmint
signedLt (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) < int32_t(y));
}

vmint
signedGt (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) > int32_t(y));
}

vmint
signedLte (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) <= int32_t(y));
}

vmint
signedGte (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) >= int32_t(y));
}

vmint
signedMul (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) * int32_t(y));
}

vmint
signedDiv (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) / int32_t(y));
}

vmint
signedMod (vmint x, vmint y)
{
  pragma(inline);
  return vmint(int32_t(x) % int32_t(y));
}

vmint
logicalNot (vmint x)
{
  pragma(inline);
  return vmint(!x);
}

vmint
logicalAnd (vmint x, vmint y)
{
  pragma(inline);
  return vmint((!!x) * (!!y));
}

vmint
logicalOr (vmint x, vmint y)
{
  pragma(inline);
  return (vmint(1) - vmint((!x) * (!y)));
}

vmint
parseDigits (string s, size_t i, size_t j)
{
  const badInteger = "bad integer";

  if (j == i)
    throw new BadVMException (badInteger);
  auto x = vmint(0);
  for (size_t k = i; k < j; k += 1)
    if (!isDigit (s[k]))
      throw new BadVMException (badInteger);
    else
      // The result is allowed to overflow freely.
      x = (vmint(10) * x) + vmint(s[k] - '0');
  return x;
}

vmint
parseInteger (string s, size_t i, size_t j)
{
  const badInteger = "bad integer";

  vmint retval;
  if (j == i)
    throw new BadVMException (badInteger);
  else if (j == i + vmint(1) && !isDigit (s[i]))
    throw new BadVMException (badInteger);
  else if (s[i] != '-')
    retval = parseDigits (s, i, j);
  else if (j == i + vmint(1))
    throw new BadVMException (badInteger);
  else
    retval = twosComplement (parseDigits (s, i + vmint(1), j));
  return retval;
}

size_t
skipWhitespace (string s, size_t n, size_t i)
{
  while (i < n && isWhite (s[i]))
    i += 1;
  return i;
}

size_t
skipNonwhitespace (string s, size_t n, size_t i)
{
  while (i < n && !isWhite (s[i]))
    i += 1;
  return i;
}

bool
substrEqual (string s, size_t i, size_t j, string t)
{
  // Is s[i .. j-1] equal to t?

  auto retval = false;
  auto m = t.length;
  if (m == j - i)
    {
      auto k = size_t(0);
      while (k < m && s[i + k] == t[k])
        k += 1;
      retval = (k == m);
    }
  return retval;
}

string
dequoteString (string s, size_t n)
{
  const badQuotedString = "bad quoted string";

  string t = "";
  s = strip(s);
  if (s.length < 2 || s[0] != '"' || s[$ - 1] != '"')
    throw new BadVMException (badQuotedString);
  auto i = 1;
  while (i < s.length - 1)
    if (s[i] != '\\')
      {
        t ~= s[i];
        i += 1;
      }
    else if (i + 1 == s.length - 1)
      throw new BadVMException (badQuotedString);
    else if (s[i + 1] == 'n')
      {
        t ~= '\n';
        i += 2;
      }
    else if (s[i + 1] == '\\')
      {
        t ~= '\\';
        i += 2;
      }
    else
      throw new BadVMException (badQuotedString);
  return t;
}

string[]
readStrings (File f, size_t stringsSize)
{
  const badQuotedString = "Bad quoted string.";

  string[] strings;
  strings.length = stringsSize;
  for (size_t k = 0; k < stringsSize; k += 1)
    {
      auto line = f.readln();
      strings[k] = dequoteString (line, line.length);
    }
  return strings;
}

ubyte
opcodeNameTo_ubyte (string str, size_t i, size_t j)
{
  size_t k = 0;
  while (k < opcodeOrder.length &&
         !substrEqual (str, i, j, opcodeOrder[k]))
    k += 1;
  if (k == opcodeOrder.length)
    throw new BadVMException ("unrecognized opcode name");
  return to!ubyte(k);
}

ubyte
vmintByte0 (vmint i)
{
  return (i & 0xFF);
}

ubyte
vmintByte1 (vmint i)
{
  return ((i >> 8) & 0xFF);
}

ubyte
vmintByte2 (vmint i)
{
  return ((i >> 16) & 0xFF);
}

ubyte
vmintByte3 (vmint i)
{
  return (i >> 24);
}

ubyte[]
parseInstruction (string line)
{
  const bad_instruction = "bad VM instruction";

  const n = line.length;
  auto i = skipWhitespace (line, n, 0);

  // Skip the address field.
  i = skipNonwhitespace (line, n, i);

  i = skipWhitespace (line, n, i);
  auto j = skipNonwhitespace (line, n, i);
  auto opcode = opcodeNameTo_ubyte (line, i, j);

  auto startOfArgument = j;

  ubyte[] finishPush ()
  {
    const i1 = skipWhitespace (line, n, startOfArgument);
    const j1 = skipNonwhitespace (line, n, i1);
    const arg = parseInteger (line, i1, j1);
    // Little-endian storage.
    return [opcode, vmintByte0 (arg), vmintByte1 (arg),
            vmintByte2 (arg), vmintByte3 (arg)];
  }

  ubyte[] finishFetchOrStore ()
  {
    const i1 = skipWhitespace (line, n, startOfArgument);
    const j1 = skipNonwhitespace (line, n, i1);
    if (j1 - i1 < 3 || line[i1] != '[' || line[j1 - 1] != ']')
      throw new BadVMException (bad_instruction);
    const arg = parseInteger (line, i1 + 1, j1 - 1);
    // Little-endian storage.
    return [opcode, vmintByte0 (arg), vmintByte1 (arg),
            vmintByte2 (arg), vmintByte3 (arg)];
  }

  ubyte[] finishJmpOrJz ()
  {
    const i1 = skipWhitespace (line, n, startOfArgument);
    const j1 = skipNonwhitespace (line, n, i1);
    if (j1 - i1 < 3 || line[i1] != '(' || line[j1 - 1] != ')')
      throw new BadVMException (bad_instruction);
    const arg = parseInteger (line, i1 + 1, j1 - 1);
    // Little-endian storage.
    return [opcode, vmintByte0 (arg), vmintByte1 (arg),
            vmintByte2 (arg), vmintByte3 (arg)];
  }

  ubyte[] retval;
  switch (opcode)
    {
    case Op.PUSH:
      retval = finishPush ();
      break;
    case Op.FETCH:
    case Op.STORE:
      retval = finishFetchOrStore ();
      break;
    case Op.JMP:
    case Op.JZ:
      retval = finishJmpOrJz ();
      break;
    default:
      retval = [opcode];
      break;
    }

  return retval;
}

ubyte[]
readCode (File f)
{
  // Read the instructions from the input, producing an array of
  // array of instruction bytes.
  ubyte[] code = [];
  auto line = f.readln();
  while (line !is null)
    {
      code ~= parseInstruction (line);
      line = f.readln();
    }
  return code;
}

void
parseHeaderLine (string line, ref size_t dataSize,
                 ref size_t stringsSize)
{
  const bad_vm_header_line = "bad VM header line";

  const n = line.length;
  auto i = skipWhitespace (line, n, 0);
  auto j = skipNonwhitespace (line, n, i);
  if (!substrEqual (line, i, j, "Datasize:"))
    throw new BadVMException (bad_vm_header_line);
  i = skipWhitespace (line, n, j);
  j = skipNonwhitespace (line, n, i);
  dataSize = parseInteger (line, i, j);
  i = skipWhitespace (line, n, j);
  j = skipNonwhitespace (line, n, i);
  if (!substrEqual (line, i, j, "Strings:"))
    throw new BadVMException (bad_vm_header_line);
  i = skipWhitespace (line, n, j);
  j = skipNonwhitespace (line, n, i);
  stringsSize = parseInteger (line, i, j);
}

VM
readVM (File f)
{
  const line = f.readln();

  size_t dataSize;
  size_t stringsSize;
  parseHeaderLine (line, dataSize, stringsSize);

  VM vm = new VM();
  vm.strings = readStrings (f, stringsSize);
  vm.code = readCode (f);
  vm.data.length = dataSize;
  vm.stack.length = 65536; // A VERY big stack, MUCH bigger than is
                           // "reasonable" for this VM. The same size
                           // as in the ATS, however.
  vm.registers[Register.PC] = vmint(0);
  vm.registers[Register.SP] = vmint(0);

  return vm;
}

vmint
pop (VM vm)
{
  pragma(inline);
  const spBefore = vm.registers[Register.SP];
  if (spBefore == 0)
    throw new VMRuntimeException ("stack underflow");
  const spAfter = spBefore - vmint(1);
  vm.registers[Register.SP] = spAfter;
  return vm.stack[spAfter];
}

void
push (VM vm, vmint x)
{
  pragma(inline);
  const spBefore = vm.registers[Register.SP];
  if (vm.stack.length <= spBefore)
    throw new VMRuntimeException ("stack overflow");
  vm.stack[spBefore] = x;
  const spAfter = spBefore + vmint(1);
  vm.registers[Register.SP] = spAfter;
}

vmint
fetchData (VM vm, vmint index)
{
  pragma(inline);
  if (vm.data.length <= index)
    throw new VMRuntimeException
      ("fetch from outside the data section");
  return vm.data[index];
}

void
storeData (VM vm, vmint index, vmint x)
{
  pragma(inline);
  if (vm.data.length <= index)
    throw new VMRuntimeException
      ("store to outside the data section");
  vm.data[index] = x;
}

vmint
getArgument (VM vm)
{
  pragma(inline);
  auto pc = vm.registers[Register.PC];
  if (vm.code.length <= pc + vmint(4))
    throw new VMRuntimeException
      ("the program counter is out of bounds");
  // The data is stored little-endian.
  const byte0 = vmint (vm.code[pc]);
  const byte1 = vmint (vm.code[pc + vmint(1)]);
  const byte2 = vmint (vm.code[pc + vmint(2)]);
  const byte3 = vmint (vm.code[pc + vmint(3)]);
  return (byte0) | (byte1 << 8) | (byte2 << 16) | (byte3 << 24);
}

void
skipArgument (VM vm)
{
  pragma(inline);
  vm.registers[Register.PC] += vmint(4);
}

//
// The string mixins below are going to do for us *some* of what the
// ATS template system did for us. The two methods hardly resemble
// each other, but both can be used to construct function definitions
// at compile time.
//

template
UnaryOperation (alias name, alias func)
{
  const char[] UnaryOperation =
    "void " ~
    name ~ " (VM vm)
    {
      pragma(inline);
      const sp = vm.registers[Register.SP];
      if (sp == vmint(0))
        throw new VMRuntimeException (\"stack underflow\");
      const x = vm.stack[sp - vmint(1)];
      const z = " ~ func ~ " (x);
      vm.stack[sp - vmint(1)] = z;
    }";
}

template
BinaryOperation (alias name, alias func)
{
  const char[] BinaryOperation =
    "void " ~
    name ~ " (VM vm)
    {
      pragma(inline);
      const spBefore = vm.registers[Register.SP];
      if (spBefore <= vmint(1))
        throw new VMRuntimeException (\"stack underflow\");
      const spAfter = spBefore - vmint(1);
      vm.registers[Register.SP] = spAfter;
      const x = vm.stack[spAfter - vmint(1)];
      const y = vm.stack[spAfter];
      const z = " ~ func ~ "(x, y);
      vm.stack[spAfter - vmint(1)] = z;
    }";
}

mixin (UnaryOperation!("uopNeg", "twosComplement"));
mixin (UnaryOperation!("uopNot", "logicalNot"));

mixin (BinaryOperation!("binopAdd", "add"));
mixin (BinaryOperation!("binopSub", "sub"));
mixin (BinaryOperation!("binopMul", "signedMul"));
mixin (BinaryOperation!("binopDiv", "signedDiv"));
mixin (BinaryOperation!("binopMod", "signedMod"));
mixin (BinaryOperation!("binopEq", "equality"));
mixin (BinaryOperation!("binopNe", "inequality"));
mixin (BinaryOperation!("binopLt", "signedLt"));
mixin (BinaryOperation!("binopGt", "signedGt"));
mixin (BinaryOperation!("binopLe", "signedLte"));
mixin (BinaryOperation!("binopGe", "signedGte"));
mixin (BinaryOperation!("binopAnd", "logicalAnd"));
mixin (BinaryOperation!("binopOr", "logicalOr"));

void
doPush (VM vm)
{
  pragma(inline);
  const arg = getArgument (vm);
  push (vm, arg);
  skipArgument (vm);
}

void
doFetch (VM vm)
{
  pragma(inline);
  const i = getArgument (vm);
  const x = fetchData (vm, i);
  push (vm, x);
  skipArgument (vm);
}

void
doStore (VM vm)
{
  pragma(inline);
  const i = getArgument (vm);
  const x = pop (vm);
  storeData (vm, i, x);
  skipArgument (vm);
}

void
doJmp (VM vm)
{
  pragma(inline);
  const arg = getArgument (vm);
  vm.registers[Register.PC] += arg;
}

void
doJz (VM vm)
{
  pragma(inline);
  const x = pop (vm);
  if (x == vmint(0))
    doJmp (vm);
  else
    skipArgument (vm);
}

void
doPrtc (File fOut, VM vm)
{
  const x = pop (vm);
  fOut.write (to!char(x));
}

void
doPrti (File fOut, VM vm)
{
  const x = pop (vm);
  fOut.write (int32_t(x));
}

void
doPrts (File fOut, VM vm)
{
  const i = pop (vm);
  if (vm.strings.length <= i)
    throw new VMRuntimeException ("string index out of bounds");
  fOut.write (vm.strings[i]);
}

void
vmStep (File fOut, VM vm, ref bool machineHalt, ref bool badOpcode)
{
  const pc = vm.registers[Register.PC];
  if (vm.code.length <= pc)
    throw new VMRuntimeException
      ("the program counter is out of bounds");
  vm.registers[Register.PC] = pc + vmint(1);
  const opcode = vm.code[pc];
  const uOpcode = uint(opcode);

  // Dispatch by bifurcation on the bit pattern of the opcode. This
  // method is logarithmic in the number of opcode values.

  machineHalt = false;
  badOpcode = false;
  if ((uOpcode & (~0x1FU)) == 0U)
    {
      if ((uOpcode & 0x10U) == 0U)
        {
          if ((uOpcode & 0x08U) == 0U)
            {
              if ((uOpcode & 0x04U) == 0U)
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        machineHalt = true;
                      else
                        binopAdd (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopSub (vm);
                      else
                        binopMul (vm);
                    }
                }
              else
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopDiv (vm);
                      else
                        binopMod (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopLt (vm);
                      else
                        binopGt (vm);
                    }
                }
            }
          else
            {
              if ((uOpcode & 0x04U) == 0U)
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopLe (vm);
                      else
                        binopGe (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopEq (vm);
                      else
                        binopNe (vm);
                    }
                }
              else
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        binopAnd (vm);
                      else
                        binopOr (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        uopNeg (vm);
                      else
                        uopNot (vm);
                    }
                }
            }
        }
      else
        {
          if ((uOpcode & 0x08U) == 0U)
            {
              if ((uOpcode & 0x04U) == 0U)
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        doPrtc (fOut, vm);
                      else
                        doPrti (fOut, vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        doPrts (fOut, vm);
                      else
                        doFetch (vm);
                    }
                }
              else
                {
                  if ((uOpcode & 0x02U) == 0U)
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        doStore (vm);
                      else
                        doPush (vm);
                    }
                  else
                    {
                      if ((uOpcode & 0x01U) == 0U)
                        doJmp (vm);
                      else
                        doJz (vm);
                    }
                }
            }
          else
            badOpcode = true;
        }
    }
  else
    badOpcode = true;
}

void
vmContinue (File fOut, VM vm)
{
  auto machineHalt = false;
  auto badOpcode = false;
  while (!machineHalt && !badOpcode)
    vmStep (fOut, vm, machineHalt, badOpcode);
  if (badOpcode)
    throw new VMRuntimeException ("unrecognized opcode at runtime");
}

void
vmInitialize (VM vm)
{
  foreach (ref x; vm.data)
    x = vmint(0);
  vm.registers[Register.PC] = vmint(0);
  vm.registers[Register.SP] = vmint(0);
}

void
vmRun (File fOut, VM vm)
{
  vmInitialize (vm);
  vmContinue (fOut, vm);
}

void
ensure_that_vmint_is_suitable ()
{
  // Try to guarantee that vmint is exactly 32 bits, and that it
  // allows overflow in either direction.
  assert (vmint(0xFFFFFFFFU) + vmint(1U) == vmint(0U));
  assert (vmint(0U) - vmint(1U) == vmint(0xFFFFFFFFU));
  assert (vmint(-1234) == twosComplement (vmint(1234)));
}

int
main (char[][] args)
{
  auto inpFilename = "-";
  auto outFilename = "-";
  if (2 <= args.length)
    inpFilename = to!string (args[1]);
  if (3 <= args.length)
    outFilename = to!string (args[2]);

  auto inpF = stdin;
  if (inpFilename != "-")
    inpF = File (inpFilename, "r");
  auto vm = readVM (inpF);
  if (inpFilename != "-")
    inpF.close();

  auto outF = stdout;
  if (outFilename != "-")
    outF = File (outFilename, "w");
  ensure_that_vmint_is_suitable ();
  vmRun (outF, vm);
  if (outFilename != "-")
    outF.close();

  return 0;
}


-module( compare_sorting_algorithms ).

-export( [task/0] ).

task() ->
	Ns = [100, 1000, 10000],
	Lists = [{"ones", fun list_of_ones/1, Ns}, {"ranges", fun list_of_ranges/1, Ns}, {"reversed_ranges", fun list_of_reversed_ranges/1, Ns}, {"shuffleds", fun list_of_shuffleds/1, Ns}],
	Sorts = [{bubble_sort, fun bubble_sort:list/1}, {insertion_sort, fun sort:insertion/1}, {iquick_sort, fun quicksort:qsort/1}],
	Results = [time_list(X, Sorts) || X <- Lists],
	[file:write_file(X++".png", egd_chart:graph(Y, [{x_label,  "log N"}, {y_label, "log ms"}])) || {X, Y} <- Results].

list_of_ones( N ) -> [1 || _X <- lists:seq(1, N)].
list_of_ranges( N ) -> [X || X <- lists:seq(1, N)].
list_of_reversed_ranges( N ) -> lists:reverse( list_of_ranges(N) ).
list_of_shuffleds( N ) -> [random:uniform(N) || _X <- lists:seq(1, N)].

time_list( {List, List_fun, Values}, Sorts ) ->
	Results = [{Sort, time_sort(Sort_fun, List_fun, Values)} || {Sort, Sort_fun} <- Sorts],
	{List, Results}.

time_sort( Sort_fun, List_fun, Values ) ->
	[time(Sort_fun, List_fun, X) || X <- Values].

time( Fun, List_fun, N ) ->
	{Time, _Result} = timer:tc( fun() -> Fun( List_fun(N) ) end ),
	{math:log10(N), math:log10(Time)}.


CREATE BUF 0 ,              \ single-character look-ahead buffer
: PEEK   BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC   PEEK  0 BUF ! ;
: SPACE?   DUP BL = SWAP 9 14 WITHIN OR ;
: >SPACE   BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
: DIGIT?   48 58 WITHIN ;
: >INT ( -- n)   >SPACE  0
   BEGIN  PEEK DIGIT?
   WHILE  GETC [CHAR] 0 -  SWAP 10 * +  REPEAT ;
CREATE A 0 ,
: [email protected] ( -- c)  A @ [email protected] ;
: [email protected]+ ( -- c)  [email protected]  1 CHARS A +! ;
: C!A+ ( c --)  A @ C!  1 CHARS A +! ;
: WORD ( -- c-addr)  >SPACE  PAD 1+ A !
   BEGIN PEEK SPACE? INVERT WHILE GETC C!A+ REPEAT
   >SPACE  PAD A @ OVER - 1- PAD C! ;
: >STRING ( -- c-addr)  >SPACE GETC DROP  PAD 1+ A !
   BEGIN PEEK [CHAR] " <> WHILE GETC C!A+ REPEAT
   GETC DROP  PAD A @ OVER - 1- PAD C! ;
: \INTERN ( c-addr -- c-addr)  HERE >R  A ! [email protected]+ DUP C,
   BEGIN DUP WHILE [email protected]+
     DUP [CHAR] \ = IF DROP -1 [email protected] +!  [email protected]+
       [CHAR] n = IF 10 ELSE [CHAR] \ THEN
     THEN C,  1-
   REPEAT  DROP R> ;
: .   0 .R ;

CREATE DATA 0 ,
CREATE STRINGS 0 ,
: >DATA   HERE DATA !
   WORD DROP  >INT 4 * BEGIN DUP WHILE 0 C, 1- REPEAT DROP ;
: >STRINGS   HERE STRINGS !
   WORD DROP  >INT DUP >R CELLS  ALLOT
   0 BEGIN DUP [email protected] < WHILE
     DUP CELLS >STRING \INTERN STRINGS @ ROT + !  1+
   REPEAT R> DROP DROP ;
: >HEADER   >DATA >STRINGS ;
: i32! ( n addr --)
   OVER           $FF AND OVER C! 1+
   OVER  8 RSHIFT $FF AND OVER C! 1+
   OVER 16 RSHIFT $FF AND OVER C! 1+
   SWAP 24 RSHIFT $FF AND SWAP C! ;
: [email protected] ( addr -- n) >R  \ This is kinda slow... hmm
   [email protected]     [email protected]
   [email protected] 1 + [email protected]  8 LSHIFT OR
   [email protected] 2 + [email protected] 16 LSHIFT OR
   R> 3 + [email protected] 24 LSHIFT OR
   DUP $7FFFFFFF AND SWAP $80000000 AND - ;  \ sign extend
: i32, ( n --)  HERE  4 ALLOT  i32! ;
: [email protected]+ ( -- n)  A @ [email protected]  A @ 4 + A ! ;
CREATE BYTECODE 0 ,
: @fetch   [email protected]+ 4 * DATA @ + [email protected] ;
: @store   [email protected]+ 4 * DATA @ + i32! ;
: @jmp     [email protected]+ BYTECODE @ + A ! ;
: @jz      IF 4 A +! ELSE @jmp THEN ;
: @prts    CELLS STRINGS @ + @ COUNT TYPE ;
: @div     >R S>D R> SM/REM SWAP DROP ;
CREATE OPS
' @fetch , ' @store , ' [email protected]+ , ' @jmp ,   ' @jz ,
' EMIT ,   ' . ,      ' @prts , ' NEGATE , ' 0= ,
' + ,      ' - ,      ' * ,     ' @div ,   ' MOD ,
' < ,      ' > ,      ' <= ,    ' >= ,
' = ,      ' <> ,     ' AND ,   ' OR ,     ' BYE ,
CREATE #OPS 0 ,
: OP:   CREATE #OPS @ ,  1 #OPS +!  DOES> @ ;
OP: fetch  OP: store  OP: push  OP: jmp  OP: jz
OP: prtc   OP: prti   OP: prts  OP: neg  OP: not
OP: add    OP: sub    OP: mul   OP: div  OP: mod
OP: lt     OP: gt     OP: le    OP: ge
OP: eq     OP: ne     OP: and   OP: or   OP: halt
: >OP   WORD FIND
   0= IF ." Unrecognized opcode" ABORT THEN EXECUTE ;
: >i32   >INT i32, ;
: >[i32]  GETC DROP >i32 GETC DROP ;
: >OFFSET   WORD DROP ( drop relative offset) >i32 ;
CREATE >PARAM  ' >[i32] DUP , , ' >i32 , ' >OFFSET DUP , ,
: >BYTECODE   HERE >R
   BEGIN >INT DROP  >OP >R  [email protected] C,
     [email protected] 5 < IF [email protected] CELLS >PARAM + @ EXECUTE THEN
   R> halt = UNTIL  R> BYTECODE ! ;
: RUN   BYTECODE @ A !
   BEGIN [email protected]+ CELLS OPS + @ EXECUTE AGAIN ;
>HEADER >BYTECODE RUN


package main

import (
    "log"
    "math/rand"
    "testing"
    "time"

    "github.com/gonum/plot"
    "github.com/gonum/plot/plotter"
    "github.com/gonum/plot/plotutil"
    "github.com/gonum/plot/vg"
)

// Step 1, sort routines.
// These functions are copied without changes from the RC tasks Bubble Sort,
// Insertion sort, and Quicksort.

func bubblesort(a []int) {
    for itemCount := len(a) - 1; ; itemCount-- {
        hasChanged := false
        for index := 0; index < itemCount; index++ {
            if a[index] > a[index+1] {
                a[index], a[index+1] = a[index+1], a[index]
                hasChanged = true
            }
        }
        if hasChanged == false {
            break
        }
    }
}

func insertionsort(a []int) {
    for i := 1; i < len(a); i++ {
        value := a[i]
        j := i - 1
        for j >= 0 && a[j] > value {
            a[j+1] = a[j]
            j = j - 1
        }
        a[j+1] = value
    }
}

func quicksort(a []int) {
    var pex func(int, int)
    pex = func(lower, upper int) {
        for {
            switch upper - lower {
            case -1, 0:
                return
            case 1:
                if a[upper] < a[lower] {
                    a[upper], a[lower] = a[lower], a[upper]
                }
                return
            }
            bx := (upper + lower) / 2
            b := a[bx]
            lp := lower
            up := upper
        outer:
            for {
                for lp < upper && !(b < a[lp]) {
                    lp++
                }
                for {
                    if lp > up {
                        break outer
                    }
                    if a[up] < b {
                        break
                    }
                    up--
                }
                a[lp], a[up] = a[up], a[lp]
                lp++
                up--
            }
            if bx < lp {
                if bx < lp-1 {
                    a[bx], a[lp-1] = a[lp-1], b
                }
                up = lp - 2
            } else {
                if bx > lp {
                    a[bx], a[lp] = a[lp], b
                }
                up = lp - 1
                lp++
            }
            if up-lower < upper-lp {
                pex(lower, up)
                lower = lp
            } else {
                pex(lp, upper)
                upper = up
            }
        }
    }
    pex(0, len(a)-1)
}

// Step 2.0 sequence routines.  2.0 is the easy part.  2.5, timings, follows.

func ones(n int) []int {
    s := make([]int, n)
    for i := range s {
        s[i] = 1
    }
    return s
}

func ascending(n int) []int {
    s := make([]int, n)
    v := 1
    for i := 0; i < n; {
        if rand.Intn(3) == 0 {
            s[i] = v
            i++
        }
        v++
    }
    return s
}

func shuffled(n int) []int {
    return rand.Perm(n)
}

// Steps 2.5 write timings, and 3 plot timings are coded together.
// If write means format and output human readable numbers, step 2.5
// is satisfied with the log output as the program runs.  The timings
// are plotted immediately however for step 3, not read and parsed from
// any formated output.
const (
    nPts = 7    // number of points per test
    inc  = 1000 // data set size increment per point
)

var (
    p        *plot.Plot
    sortName = []string{"Bubble sort", "Insertion sort", "Quicksort"}
    sortFunc = []func([]int){bubblesort, insertionsort, quicksort}
    dataName = []string{"Ones", "Ascending", "Shuffled"}
    dataFunc = []func(int) []int{ones, ascending, shuffled}
)

func main() {
    rand.Seed(time.Now().Unix())
    var err error
    p, err = plot.New()
    if err != nil {
        log.Fatal(err)
    }
    p.X.Label.Text = "Data size"
    p.Y.Label.Text = "microseconds"
    p.Y.Scale = plot.LogScale{}
    p.Y.Tick.Marker = plot.LogTicks{}
    p.Y.Min = .5 // hard coded to make enough room for legend

    for dx, name := range dataName {
        s, err := plotter.NewScatter(plotter.XYs{})
        if err != nil {
            log.Fatal(err)
        }
        s.Shape = plotutil.DefaultGlyphShapes[dx]
        p.Legend.Add(name, s)
    }
    for sx, name := range sortName {
        l, err := plotter.NewLine(plotter.XYs{})
        if err != nil {
            log.Fatal(err)
        }
        l.Color = plotutil.DarkColors[sx]
        p.Legend.Add(name, l)
    }
    for sx := range sortFunc {
        bench(sx, 0, 1) // for ones, a single timing is sufficient.
        bench(sx, 1, 5) // ascending and shuffled have some randomness though,
        bench(sx, 2, 5) // so average timings on 5 different random sets.
    }

    if err := p.Save(5*vg.Inch, 5*vg.Inch, "comp.png"); err != nil {
        log.Fatal(err)
    }
}

func bench(sx, dx, rep int) {
    log.Println("bench", sortName[sx], dataName[dx], "x", rep)
    pts := make(plotter.XYs, nPts)
    sf := sortFunc[sx]
    for i := range pts {
        x := (i + 1) * inc
        // to avoid timing sequence creation, create sequence before timing
        // then just copy the data inside the timing loop.  copy time should
        // be the same regardless of sequence data.
        s0 := dataFunc[dx](x) // reference sequence
        s := make([]int, x)   // working copy
        var tSort int64
        for j := 0; j < rep; j++ {
            tSort += testing.Benchmark(func(b *testing.B) {
                for i := 0; i < b.N; i++ {
                    copy(s, s0)
                    sf(s)
                }
            }).NsPerOp()
        }
        tSort /= int64(rep)
        log.Println(x, "items", tSort, "ns") // step 2.5, write timings
        pts[i] = struct{ X, Y float64 }{float64(x), float64(tSort) * .001}
    }
    pl, ps, err := plotter.NewLinePoints(pts) // step 3, plot timings
    if err != nil {
        log.Fatal(err)
    }
    pl.Color = plotutil.DarkColors[sx]
    ps.Color = plotutil.DarkColors[sx]
    ps.Shape = plotutil.DefaultGlyphShapes[dx]
    p.Add(pl, ps)
}