/*REXX pgm compares various sorts for 3 types of input sequences: ones/ascending/random.*/
parse arg ranges start# seed .                   /*obtain optional arguments from the CL*/
if ranges=='' | ranges==","  then ranges=     5  /*Not Specified?  Then use the default.*/
if start#=='' | start#==","  then start#=   250  /* "      "         "   "   "     "    */
if   seed=='' |   seed==","  then   seed=  1946  /*use a repeatable seed for RANDOM  BIF*/
if datatype(seed, 'W')  then call random ,,seed  /*Specified?  Then use as a RANDOM seed*/
kinds= 3;      hdr=;       #= start#             /*hardcoded/fixed number of datum kinds*/
   do ra=1  for ranges
   hdr= hdr || center( commas(#) "numbers", 25)'│'  /*(top) header for the output title.*/
     do ki=1  for kinds
     call [email protected]@ #, ki
     call [email protected];  call time 'R';  call bubble     #;     bubble.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call cocktail   #;   cocktail.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call cocktailSB #; cocktailSB.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call comb       #;       comb.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call exchange   #;   exchange.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call gnome      #;      gnome.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call heap       #;       heap.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call insertion  #;  insertion.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call merge      #;      merge.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call pancake    #;    pancake.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call quick      #;      quick.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call radix      #;      radix.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call selection  #;  selection.ra.ki= format(time("E"),,2)
     call [email protected];  call time 'R';  call shell      #;      shell.ra.ki= format(time("E"),,2)
     end   /*ki*/
   #= # + #                                                         /*double # elements.*/
   end     /*ra*/
say;                             say;    say                        /*say blank sep line*/
say center('         ', 11     ) "│"left(hdr, length(hdr)-1)"│"     /*replace last char.*/
                            reps= ' allONES  ascend  random │'      /*build a title bar.*/
xreps=       copies( center(reps, length(reps)), ranges)            /*replicate ranges. */
creps= left(xreps, length(xreps)-1)"│"                              /*replace last char.*/
say center('sort type', 11     ) "│"creps;                       Lr= length(reps)
                                        xcreps= copies( left('', Lr-1, '─')"┼", ranges)
say center(''         , 12, '─')"┼"left(xcreps, length(xcreps)-1)"┤"
call show 'bubble'                               /* ◄──── show results for bubble  sort.*/
call show 'cocktail'                             /* ◄────   "     "     "  cocktail   " */
call show 'cocktailSB'    /*+Shifting Bounds*/   /* ◄────   "     "     "  cocktailSB " */
call show 'comb'                                 /* ◄────   "     "     "  comb       " */
call show 'exchange'                             /* ◄────   "     "     "  exchange   " */
call show 'gnome'                                /* ◄────   "     "     "  gnome      " */
call show 'heap'                                 /* ◄────   "     "     "  heap       " */
call show 'insertion'                            /* ◄────   "     "     "  insertion  " */
call show 'merge'                                /* ◄────   "     "     "  merge      " */
call show 'pancake'                              /* ◄────   "     "     "  pancake    " */
call show 'quick'                                /* ◄────   "     "     "  quick      " */
call show 'radix'                                /* ◄────   "     "     "  radix      " */
call show 'selection'                            /* ◄────   "     "     "  shell      " */
call show 'shell'                                /* ◄────   "     "     "  shell      " */
say translate(center(''         , 12, '─')"┴"left(xcreps, length(xcreps)-1)"┘",  '┴', "┼")
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
commas: parse arg ?;  do jc=length(?)-3  to 1  by -3; ?=insert(',', ?, jc); end;  return ?
inOrder: parse arg n; do j=1  for n-1;  k= j+1;  if @.j>@.k  then return 0; end;  return 1
[email protected]:   @.=;          do a=1  for #;                 @.a= @@.a;             end;  return
/*──────────────────────────────────────────────────────────────────────────────────────*/
[email protected]@: procedure expose @@.; parse arg n,kind;  nn= min(n, 100000)     /*1e5≡REXX's max.*/
              do j=1 for nn;      select
                                  when kind==1  then  @@.j= 1               /*all ones. */
                                  when kind==2  then  @@.j= j               /*ascending.*/
                                  when kind==3  then  @@.j= random(, nn)    /*random.   */
                                  end   /*select*/
              end   /*j*/;                                              return
/*──────────────────────────────────────────────────────────────────────────────────────*/
show:  parse arg aa;  _= left(aa, 11)  "│"
                                do   ra=1  for ranges
                                  do ki=1  for kinds
                                  _= _  right( value(aa || . || ra || . || ki),  7, ' ')
                                  end   /*k*/
                                _= _  "│"
                                end     /*r*/;       say _;             return
/*──────────────────────────────────────────────────────────────────────────────────────*/
bubble:   procedure expose @.;  parse arg n         /*N: is the number of  @  elements. */
            do m=n-1  by -1  until ok;         ok=1 /*keep sorting  @  array until done.*/
              do j=1  for m;  k=j+1;  if @.j<[email protected].k  then iterate    /*elements in order? */
              [email protected].j;  @.[email protected].k;  @.k=_;         ok=0 /*swap 2 elements; flag as not done.*/
              end   /*j*/
            end     /*m*/;                                              return
/*──────────────────────────────────────────────────────────────────────────────────────*/
cocktail: procedure expose @.;    parse arg N;   nn= N-1     /*N:  is number of items.  */
            do until done;   done= 1
                do j=1   for nn;                jp= j+1
                if @.j>@.jp  then do;  done=0;  [email protected].j;  @.[email protected].jp;  @.jp=_;  end
                end   /*j*/
            if done  then leave                              /*No swaps done?  Finished.*/
                do k=nn  for nn  by -1;         kp= k+1
                if @.k>@.kp  then do;  done=0;  [email protected].k;  @.[email protected].kp;  @.kp=_;  end
                end   /*k*/
            end       /*until*/;                                        return
/*──────────────────────────────────────────────────────────────────────────────────────*/
cocktailsb: procedure expose @.;    parse arg N              /*N:  is number of items.  */
                             end$= N - 1;     beg$= 1
            do while beg$ <= end$
            beg$$= end$;               end$$= beg$
                do j=beg$ to end$;                   jp= j + 1
                if @.j>@.jp  then do;  [email protected].j;  @.[email protected].jp;  @.jp=_;  end$$=j;  end
                end   /*j*/
            end$= end$$ - 1
                do k=end$  to beg$  by -1;           kp= k + 1
                if @.k>@.kp  then do;  [email protected].k;  @.[email protected].kp;  @.kp=_;  beg$$=k;  end
                end   /*k*/
            beg$= beg$$ + 1
            end       /*while*/;                                        return
/*──────────────────────────────────────────────────────────────────────────────────────*/
comb:  procedure expose @.;   parse arg n        /*N:  is the number of  @  elements.   */
       g= n-1                                    /*G:  is the gap between the sort COMBs*/
             do  until g<=1 & done;    done= 1   /*assume sort is done  (so far).       */
             g= g * 0.8  % 1                     /*equivalent to:   g= trunc( g / 1.25) */
             if g==0  then g= 1                  /*handle case of the gap is too small. */
                do j=1  until $>=n;    $= j + g  /*$:     a temporary index  (pointer). */
                if @.j>@.$  then do;   _= @.j;     @.j= @.$;    @.$= _;    done= 0;    end
                end   /*j*/                      /* [↑]  swap two elements in the array.*/
             end      /*until*/;       return
/*──────────────────────────────────────────────────────────────────────────────────────*/
exchange: procedure expose @.;  parse arg n 1 h  /*both  N  and  H  have the array size.*/
             do while h>1;                      h= h % 2
                do i=1  for n-h;       j= i;    k= h+i
                   do while @.k<@.j
                   _= @.j;  @.j= @.k;  @.k= _;  if h>=j  then leave;  j= j-h;  k= k-h
                   end   /*while @.k<@.j*/
                end      /*i*/
             end         /*while h>1*/;                       return
/*──────────────────────────────────────────────────────────────────────────────────────*/
gnome: procedure expose @.;  parse arg n;      k= 2               /*N: is number items. */
          do j=3  while k<=n;                  p= k - 1           /*P: is previous item.*/
          if @.p<<[email protected].k  then do;      k= j;    iterate;   end     /*order is OK so far. */
          _= @.p;       @.p= @.k;     @.k= _                      /*swap two @ entries. */
          k= k - 1;     if k==1  then k= j;    else j= j-1        /*test for 1st index. */
          end    /*j*/;                                return
/*──────────────────────────────────────────────────────────────────────────────────────*/
heap:  procedure expose @.; arg n;  do j=n%2  by -1  to 1;   call heapS j,n;  end  /*j*/
             do n=n  by -1  to 2;    _= @.1;    @.1= @.n;    @.n= _;   call heapS 1,n-1
             end   /*n*/;           return       /* [↑]  swap two elements; and shuffle.*/

heapS: procedure expose @.;  parse arg i,n;        $= @.i            /*obtain parent.*/
             do  while i+i<=n;   j= i+i;   k= j+1;    if k<=n  then  if @.k>@.j  then j= k
             if $>[email protected].j  then leave;      @.i= @.j;    i= j
             end   /*while*/;            @.i= $;      return            /*define lowest.*/
/*──────────────────────────────────────────────────────────────────────────────────────*/
insertion:  procedure expose @.;   parse arg n
                   do i=2  to n;   $= @.i;       do j=i-1  by -1  to 1  while @.j>$
                                                 _= j + 1;        @._= @.j
                                                 end   /*j*/
                   _= j + 1;       @._= $
                   end   /*i*/;                                         return
/*──────────────────────────────────────────────────────────────────────────────────────*/
merge: procedure expose @. !.;   parse arg n, L;   if L==''  then do;  !.=;  L= 1;  end
          if n==1  then return;     h= L + 1
          if n==2  then do; if @.L>@.h  then do; [email protected].h; @.[email protected].L; @.L=_; end; return;  end
          m= n % 2                                     /* [↑]  handle case of two items.*/
          call merge  n-m, L+m                         /*divide items  to the left   ···*/
          call merger m,   L,   1                      /*   "     "     "  "  right  ···*/
          i= 1;                     j= L + m
                     do k=L  while k<j                 /*whilst items on right exist ···*/
                     if j==L+n  |  !.i<[email protected].j  then do;     @.k= !.i;     i= i + 1;      end
                                             else do;     @.k= @.j;     j= j + 1;      end
                     end   /*k*/;                         return

merger: procedure expose @. !.;  parse arg n,L,T
           if n==1  then do;  !.T= @.L;                                       return;  end
           if n==2  then do;  h= L + 1;   q= T + 1;  !.q= @.L;    !.T= @.h;   return;  end
           m= n % 2                                    /* [↑]  handle case of two items.*/
           call merge  m,   L                          /*divide items  to the left   ···*/
           call merger n-m, L+m, m+T                   /*   "     "     "  "  right  ···*/
           i= L;                     j= m + T
                     do k=T  while k<j                 /*whilst items on left exist  ···*/
                     if j==T+n  |  @.i<=!.j  then do;     !.k= @.i;     i= i + 1;      end
                                             else do;     !.k= !.j;     j= j + 1;      end
                     end   /*k*/;                         return
/*──────────────────────────────────────────────────────────────────────────────────────*/
pancake: procedure expose @.;   parse arg n .;               if inOrder(n)  then return
             do n=n  by -1  for n-1
             != @.1;   ?= 1;                do j=2  to n;    if @.j<=!  then iterate
                                            != @.j;          ?= j
                                            end   /*j*/
             call panFlip ?;   call panFlip n
             end   /*n*/;                                               return

panFlip: parse arg y;  do i=1  for (y+1)%2; yi=y-i+1; [email protected].i; @.[email protected].yi; @.yi=_; end; return
/*──────────────────────────────────────────────────────────────────────────────────────*/
quick: procedure expose @.; a.1=1; parse arg b.1; $= 1 /*access @.; get #; define pivot.*/
       if inOrder(b.1)  then return
             do  while  $\==0;     L= a.$;    t= b.$;     $= $-1;   if t<2  then iterate
             H= L+t-1;             ?= L+t%2
             if @.H<@.L  then if @.?<@.H  then do;  [email protected].H;  @.[email protected].L;  end
                                          else if @.?>@.L  then [email protected].L
                                                           else do;  [email protected].?;  @.[email protected].L;  end
                         else if @.?<@.L  then [email protected].L
                                          else if @.?>@.H  then do;  [email protected].H;  @.[email protected].L;  end
                                                           else do;  [email protected].?;  @.[email protected].L;  end
             j= L+1;                           k=h
                    do forever
                        do j=j         while j<k & @.j<=p;  end     /*a tinie─tiny loop.*/
                        do k=k  by -1  while j<k & @.k>=p;  end     /*another   "    "  */
                    if j>=k  then leave                             /*segment finished? */
                    _= @.j;       @.j= @.k;             @.k= _      /*swap J&K elements.*/
                    end   /*forever*/
             $= $+1;            k= j-1;   @.L= @.k;     @.k= p
             if j<=?  then do;  a.$= j;   b.$= H-j+1;   $= $+1;  a.$= L;  b.$= k-L;    end
                      else do;  a.$= L;   b.$= k-L;     $= $+1;  a.$= j;  b.$= H-j+1;  end
             end          /*while $¬==0*/;              return
/*──────────────────────────────────────────────────────────────────────────────────────*/
radix:   procedure expose @.;  parse arg size,w;   mote= c2d(' ');    #= 1;   !.#._n= size
!.#._b= 1;                     if w==''  then w= 8
!.#._i= 1;  do i=1  for size;  [email protected].i;  @.i= right(abs(y), w, 0);  if y<0  then @.i= '-'@.i
            end  /*i*/                                            /* [↑]  negative case.*/

     do  while #\==0;  ctr.= 0;  L= 'ffff'x;   low= !.#._b;   n= !.#._n;   $= !.#._i;   H=
     #= #-1                                                      /* [↑]   is the radix. */
           do j=low  for n;      parse var  @.j  =($)  _  +1;    ctr._= ctr._ + 1
           if ctr._==1 & _\==''  then do;  if _<<L  then L=_;    if _>>H  then H=_
                                      end  /*  ↑↑                                       */
           end   /*j*/                     /*  └┴─────◄───  <<   is a strict comparison.*/
     _=                                    /*      ┌──◄───  >>    " "    "        "     */
     if L>>H  then iterate                 /*◄─────┘                                    */
     if L==H & ctr._==0  then do; #= #+1;  !.#._b= low;  !.#._n= n;  !.#._i= $+1;  iterate
                              end
     L= c2d(L);   H= c2d(H);      ?= ctr._ + low;        top._= ?;          ts= mote
     max= L
                  do k=L  to H;   _= d2c(k, 1);   c= ctr._  /* [↓]  swap 2 item radices.*/
                  if c>ts  then parse value  c k  with  ts max;     ?= ?+c;       top._= ?
                  end   /*k*/
     piv= low                                    /*set PIVot to the low part of the sort*/
             do  while piv<low+n
             it= @.piv
                        do forever;     parse var it  =($)  _  +1;         c= top._ -1
                        if piv>=c  then leave;   top._= c;    ?= @.c;    @.c= it;    it= ?
                        end   /*forever*/
             top._= piv;                         @.piv= it;        piv= piv + ctr._
             end   /*while piv<low+n */
     i= max
          do  until i==max;  _= d2c(i, 1);     i= i+1;     if i>H  then i= L;     d= ctr._
          if d<=mote  then do;         if d<2  then iterate;          b= top._
                             do k=b+1  for d-1;                       q= @.k
                               do j=k-1  by -1  to b  while q<<@.j;  jp= j+1;   @.jp= @.j
                               end   /*j*/
                                                                     jp= j+1;   @.jp= q
                             end     /*k*/
                           iterate
                           end
          #= #+1;       !.#._b= top._;       !.#._n= d;        !.#._i= $ + 1
          end   /*until i==max*/
     end        /*while #\==0 */
#= 0                                             /* [↓↓↓]  handle neg. and pos. arrays. */
        do i=size  by -1  for size;    if @.i>=0  then iterate;     #= #+1;      @@.#= @.i
        end   /*i*/
        do j=1  for size;   if @.j>=0  then do;  #= #+1;   @@.#= @.j;  end;    @.j= @@.j+0
        end   /*j*/                              /* [↑↑↑]  combine 2 lists into 1 list. */
return
/*──────────────────────────────────────────────────────────────────────────────────────*/
selection: procedure expose @.;  parse arg n
              do j=1  for n-1;         _= @.j;         p= j
                  do k=j+1  to n;      if @.k>=_  then iterate
                  _= @.k;              p= k      /*this item is out─of─order, swap later*/
                  end   /*k*/
              if p==j  then iterate              /*if the same, the order of items is OK*/
              _= @.j;     @.j= @.p;    @.p=      /*swap 2 items that're out─of─sequence.*/
              end       /*j*/;         return
/*──────────────────────────────────────────────────────────────────────────────────────*/
shell: procedure expose @.;   parse arg N        /*obtain the  N  from the argument list*/
       i= N % 2                                  /*%   is integer division in REXX.     */
                  do  while i\==0
                         do j=i+1  to N;    k= j;      p= k-i         /*P: previous item*/
                         _= @.j
                                do  while k>=i+1 & @.p>_;   @.k= @.p;    k= k-i;    p= k-i
                                end   /*while k≥i+1*/
                         @.k= _
                         end          /*j*/
                  if i==2  then i= 1
                           else i= i * 5 % 11
                  end                 /*while i¬==0*/;                  return


Module Virtual_Machine_Interpreter (a$){
	\\ function to extract string, replacing escape codes.
	Function GetString$(a$) {
		s=instr(a$, chr$(34))
		m=rinstr(a$,chr$(34))-s
		if m>1 then
			\\ process escape codes
			=format$(mid$(a$, s+1, m-1))
		else
			=""
		end if
	}
	\\ module to print a string to console using codes, 13, 10, 9
	Module printsrv (a$) {
		for i=1 to len(a$)
			select case chrcode(Mid$(a$,i,1))
			case 13
				cursor 0
			case 10
				cursor 0 : Print
			case 9
				cursor ((pos+tab) div tab)*tab
			else case
			{
				m=pos :if pos>=width then Print : m=pos
				Print Mid$(a$,i,1);
				if m<=width then cursor m+1
			}
			end select
		next i
	}
	const nl$=chr$(13)+chr$(10)
	\\ we can set starting value to any number  n where 0<=n<=232
	enum op {	halt_=232, add_, sub_, mul_, div_, mod_, not_, neg_, and_, or_, lt_,
		    	gt_, le_, ge_, ne_, eq_, prts_, prti_, prtc_, store_, fetch_, push_,
			jmp_, jz_
    	}
	Rem : Form 120, 60 ' change console width X height to run Ascii Mandlebrot examlpe
	Report "Virtual Assembly Code:"+{
	}+a$
	Print "Prepare Byte Code"

	\\ get datasize
	a$=rightpart$(a$, "Datasize:")
	m=0
	data_size=val(a$, "int", m)
	a$=mid$(a$, m)
	\\ make stack
	if data_size>0 then Buffer Clear stack_ as long*data_size
	\\ dim or redim buffer append 1000 long as is.
	Buffer stack_ as long*(1000+data_size)
	\\ get strings
	a$=rightpart$(a$, "Strings:")
	m=0
	strings=val(a$, "int", m)
	a$=rightpart$(a$, nl$)

	if strings>0 then
		Dim strings$(strings)
		for i=0 to strings-1
			strings$(i)=GetString$(leftpart$(a$, nl$))
			a$=rightpart$(a$, nl$)
		Next i
	End if
	buffer clear code_ as byte*1000
	do
		m=0
		offset=val(a$,"int", m)
		if m<0 then exit
		a$=mid$(a$,m)
		line$=trim$(leftpart$(a$,nl$))
		if line$="" then line$=trim$(a$) else a$=trim$(rightpart$(a$, nl$))
		op$=if$(instr(line$," ")>0->leftpart$(line$," "), line$)
		if not valid(eval(op$+"_")) then exit
		opc=eval(op$+"_")
		Return code_, offset:=opc
		if opc>=store_ then
			line$=rightpart$(line$," ")
			select case opc
			case store_, fetch_
				Return code_, offset+1:=val(rightpart$(leftpart$(line$,"]"),"[")) as long : offset+=4
			case push_
				Return code_, offset+1:=uint(val(line$)) as long : offset+=4
			case jz_, jmp_
				Return code_, offset+1:=val(rightpart$(line$,")")) as long : offset+=4
			end select
		end if
	Always
	Print "Press any key" : Push key$ : Drop
	\\ Prepare VM
	let pc=0, sp=len(stack_) div 4
	do {
		func=eval(code_, pc)
		pc++
		select case func
		case halt_
			exit
		case push_
			sp--:return stack_, sp:=eval(code_, pc as long):pc+=4
		case jz_
			sp++: if eval(stack_, sp-1)=0 then pc=eval(code_, pc as long) else pc+=4
		case jmp_
			pc=eval(code_, pc as long)
		case fetch_
			sp--:Return stack_, sp:=eval(stack_, eval(code_, pc as long)):pc+=4
		case store_
			Return stack_, eval(code_, pc as long):=eval(stack_, sp):sp++:pc+=4
		case add_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))+sint(eval(stack_, sp))):sp++
		case sub_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))-sint(eval(stack_, sp))):sp++
		case mul_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1))*sint(eval(stack_, sp))):sp++
		case div_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) div sint(eval(stack_, sp))):sp++
		case mod_
			Return stack_, sp+1:=uint(sint(eval(stack_, sp+1)) mod sint(eval(stack_, sp))) :sp++
		case not_
			Return stack_, sp:=if(eval(stack_, sp)=0->uint(-1),0)
		case neg_  \\ we can use neg(sint(value))+1 or uint(-sint(value))
			Return stack_, sp:=uint(-sint(eval(stack_, sp)))
		case and_
			Return stack_, sp+1:=binary.and(eval(stack_, sp+1),eval(stack_, sp)):sp++
		case or_
			Return stack_, sp+1:=binary.or(eval(stack_, sp+1),eval(stack_, sp)):sp++
		case lt_
			Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<sint(eval(stack_, sp))->-1, 0)):sp++
		case gt_
			Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>sint(eval(stack_, sp))->-1, 0)):sp++
		case le_
			Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))<=sint(eval(stack_, sp))->-1, 0)):sp++
		case ge_
			Return stack_, sp+1:=uint(if(sint(eval(stack_, sp+1))>=sint(eval(stack_, sp))->-1, 0)):sp++
		case ne_
			Return stack_, sp+1:=uint(if(eval(stack_, sp+1)<>eval(stack_, sp)->-1, 0)):sp++
		case eq_
			Return stack_, sp+1:=uint(if(eval(stack_, sp+1)=eval(stack_, sp)->-1, 0)):sp++
		case prts_
			printsrv strings$(eval(stack_,sp)):sp++
		case prti_
			printsrv str$(sint(eval(stack_,sp)),0):sp++
		case prtc_
			printsrv chrcode$(eval(stack_,sp)):sp++
		else case
			Error "Unkown op "+str$(func)
		end select
	} always
	Print "done"
}
Virtual_Machine_Interpreter {
Datasize: 1 Strings: 2
"count is: "
"\n"
    0 push  1
    5 store [0]
   10 fetch [0]
   15 push  10
   20 lt
   21 jz     (43) 65
   26 push  0
   31 prts
   32 fetch [0]
   37 prti
   38 push  1
   43 prts
   44 fetch [0]
   49 push  1
   54 add
   55 store [0]
   60 jmp    (-51) 10
   65 halt
}


class Array
  def radix_sort(base=10)       # negative value is inapplicable.
    ary = dup
    rounds = (Math.log(ary.max)/Math.log(base)).ceil
    rounds.times do |i|
      buckets = Array.new(base){[]}
      base_i = base**i
      ary.each do |n|
        digit = (n/base_i) % base
        buckets[digit] << n
      end
      ary = buckets.flatten
    end
    ary
  end

  def quick_sort
    return self  if size <= 1
    pivot = sample
    g = group_by{|x| x<=>pivot}
    g.default = []
    g[-1].quick_sort + g[0] + g[1].quick_sort
  end

  def shell_sort
    inc = size / 2
    while inc > 0
      (inc...size).each do |i|
        value = self[i]
        while i >= inc and self[i - inc] > value
          self[i] = self[i - inc]
          i -= inc
        end
        self[i] = value
      end
      inc = (inc == 2 ? 1 : (inc * 5.0 / 11).to_i)
    end
    self
  end

  def insertion_sort
    (1...size).each do |i|
      value = self[i]
      j = i - 1
      while j >= 0 and self[j] > value
        self[j+1] = self[j]
        j -= 1
      end
      self[j+1] = value
    end
    self
  end

  def bubble_sort
    (1...size).each do |i|
      (0...size-i).each do |j|
        self[j], self[j+1] = self[j+1], self[j]  if self[j] > self[j+1]
      end
    end
    self
  end
end

data_size = [1000, 10000, 100000, 1000000]
data = []
data_size.each do |size|
  ary = *1..size
  data << [ [1]*size, ary, ary.shuffle, ary.reverse ]
end
data = data.transpose

data_type = ["set to all ones", "ascending sequence", "randomly shuffled", "descending sequence"]
print "Array size:          "
puts data_size.map{|size| "%9d" % size}.join

data.each_with_index do |arys,i|
  puts "\nData #{data_type[i]}:"
  [:sort, :radix_sort, :quick_sort, :shell_sort, :insertion_sort, :bubble_sort].each do |m|
    printf "%20s ", m
    flag = true
    arys.each do |ary|
      if flag
        t0 = Time.now
        ary.dup.send(m)
        printf "  %7.3f", (t1 = Time.now - t0)
        flag = false  if t1 > 2
      else
        print "   --.---"
      end
    end
    puts
  end
end


F commatize(s, period = 3, sep = ‘,’)
   V m = re:‘(\.[0-9]+|[1-9]([0-9]+)?(\.[0-9]+)?)’.search(s)
   I !m
      R s

   V match = m.group()
   V splits = match.split(‘.’)

   V ip = splits[0]
   I ip.len > period
      V inserted = 0
      L(i) ((ip.len - 1) % period + 1 .< ip.len).step(period)
         ip = ip[0 .< i + inserted]‘’sep‘’ip[i + inserted ..]
         inserted += sep.len

   I splits.len > 1
      V dp = splits[1]
      I dp.len > period
         L(i) ((dp.len - 1) I/ period * period .< period - 1).step(-period)
            dp = dp[0 .< i]‘’sep‘’dp[i..]
      ip ‘’= ‘.’dp

   R s[0 .< m.start()]‘’ip‘’s[m.end()..]

V tests = [‘123456789.123456789’,
           ‘.123456789’,
           ‘57256.1D-4’,
           ‘pi=3.14159265358979323846264338327950288419716939937510582097494459231’,
           ‘The author has two Z$100000000000000 Zimbabwe notes (100 trillion).’,
           ‘-in Aus$+1411.8millions’,
           ‘===US$0017440 millions=== (in 2000 dollars)’,
           ‘123.e8000 is pretty big.’,
           ‘The land area of the earth is 57268900(29% of the surface) square miles.’,
           ‘Ain't no numbers in this here words, nohow, no way, Jose.’,
           ‘James was never known as 0000000007’,
           ‘Arthur Eddington wrote: I believe there are ’""
             ‘15747724136275002577605653961181555468044717914527116709366231425076185631031296’""
             ‘ protons in the universe.’,
           ‘   $-140000±100 millions.’,
           ‘6/9/1946 was a good year for some.’]

print(commatize(tests[0], period' 2, sep' ‘*’))
print(commatize(tests[1], period' 3, sep' ‘-’))
print(commatize(tests[2], period' 4, sep' ‘__’))
print(commatize(tests[3], period' 5, sep' ‘ ’))
print(commatize(tests[4], sep' ‘.’))

L(test) tests[5..]
   print(commatize(test))


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% The Rosetta Code Virtual Machine, in Mercury.
%%%
%%% (This particular machine is arbitrarily chosen to be big-endian.)
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

:- module vm.

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

:- implementation.
:- import_module array.
:- import_module bool.
:- import_module char.
:- import_module exception.
:- import_module int.
:- import_module int32.
:- import_module list.
:- import_module string.
:- import_module uint.
:- import_module uint8.
:- import_module uint32.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% uint32 operations.
%%%

:- func twos_cmp(uint32) = uint32.
:- mode twos_cmp(in) = out is det.
:- pragma inline(twos_cmp/1).
twos_cmp(U) = NegU :-
  (NegU = (\U) + 1_u32).

:- func unsigned_add(uint32, uint32) = uint32.
:- mode unsigned_add(in, in) = out is det.
:- pragma inline(unsigned_add/2).
unsigned_add(U, V) = U_plus_V :-
  (U_plus_V = U + V).

:- func unsigned_sub(uint32, uint32) = uint32.
:- mode unsigned_sub(in, in) = out is det.
:- pragma inline(unsigned_sub/2).
unsigned_sub(U, V) = U_minus_V :-
  (U_minus_V = U - V).

:- func signed_mul(uint32, uint32) = uint32.
:- mode signed_mul(in, in) = out is det.
:- pragma inline(signed_mul/2).
signed_mul(U, V) = UV :-
  UV = cast_from_int32(cast_from_uint32(U) * cast_from_uint32(V)).

:- func signed_quot(uint32, uint32) = uint32.
:- mode signed_quot(in, in) = out is det.
:- pragma inline(signed_quot/2).
signed_quot(U, V) = U_quot_V :- % Truncation towards zero.
  U_quot_V = cast_from_int32(cast_from_uint32(U)
                             // cast_from_uint32(V)).

:- func signed_rem(uint32, uint32) = uint32.
:- mode signed_rem(in, in) = out is det.
:- pragma inline(signed_rem/2).
signed_rem(U, V) = U_rem_V :-   % Truncation towards zero, sign of U.
  U_rem_V = cast_from_int32(cast_from_uint32(U)
                            rem cast_from_uint32(V)).

:- func signed_lt(uint32, uint32) = uint32.
:- mode signed_lt(in, in) = out is det.
:- pragma inline(signed_lt/2).
signed_lt(U, V) = U_lt_V :-
  if (int32.cast_from_uint32(U) < int32.cast_from_uint32(V))
  then (U_lt_V = 1_u32)
  else (U_lt_V = 0_u32).

:- func signed_le(uint32, uint32) = uint32.
:- mode signed_le(in, in) = out is det.
:- pragma inline(signed_le/2).
signed_le(U, V) = U_le_V :-
  if (int32.cast_from_uint32(U) =< int32.cast_from_uint32(V))
  then (U_le_V = 1_u32)
  else (U_le_V = 0_u32).

:- func signed_gt(uint32, uint32) = uint32.
:- mode signed_gt(in, in) = out is det.
:- pragma inline(signed_gt/2).
signed_gt(U, V) = U_gt_V :-
  U_gt_V = signed_lt(V, U).

:- func signed_ge(uint32, uint32) = uint32.
:- mode signed_ge(in, in) = out is det.
:- pragma inline(signed_ge/2).
signed_ge(U, V) = U_ge_V :-
  U_ge_V = signed_le(V, U).

:- func unsigned_eq(uint32, uint32) = uint32.
:- mode unsigned_eq(in, in) = out is det.
:- pragma inline(unsigned_eq/2).
unsigned_eq(U, V) = U_eq_V :-
  if (U = V)
  then (U_eq_V = 1_u32)
  else (U_eq_V = 0_u32).

:- func unsigned_ne(uint32, uint32) = uint32.
:- mode unsigned_ne(in, in) = out is det.
:- pragma inline(unsigned_ne/2).
unsigned_ne(U, V) = U_ne_V :-
  if (U \= V)
  then (U_ne_V = 1_u32)
  else (U_ne_V = 0_u32).

:- func logical_cmp(uint32) = uint32.
:- mode logical_cmp(in) = out is det.
:- pragma inline(logical_cmp/1).
logical_cmp(U) = NotU :-
  if (U = 0_u32)
  then (NotU = 1_u32)
  else (NotU = 0_u32).

:- func logical_and(uint32, uint32) = uint32.
:- mode logical_and(in, in) = out is det.
:- pragma inline(logical_and/2).
logical_and(U, V) = U_and_V :-
  if (U \= 0_u32, V \= 0_u32)
  then (U_and_V = 1_u32)
  else (U_and_V = 0_u32).

:- func logical_or(uint32, uint32) = uint32.
:- mode logical_or(in, in) = out is det.
:- pragma inline(logical_or/2).
logical_or(U, V) = U_or_V :-
  if (U \= 0_u32; V \= 0_u32)
  then (U_or_V = 1_u32)
  else (U_or_V = 0_u32).

:- pred to_bytes(uint32, uint8, uint8, uint8, uint8).
:- mode to_bytes(in, out, out, out, out) is det.
:- pragma inline(to_bytes/5).
to_bytes(U, B3, B2, B1, B0) :-
  (B0 = cast_from_int(cast_to_int(U /\ 0xFF_u32))),
  (B1 = cast_from_int(cast_to_int((U >> 8) /\ 0xFF_u32))),
  (B2 = cast_from_int(cast_to_int((U >> 16) /\ 0xFF_u32))),
  (B3 = cast_from_int(cast_to_int((U >> 24) /\ 0xFF_u32))).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% String operations.
%%%

:- pred digit_u32(char, uint32).
:- mode digit_u32(in, out) is semidet.
digit_u32(('0'), 0_u32).
digit_u32(('1'), 1_u32).
digit_u32(('2'), 2_u32).
digit_u32(('3'), 3_u32).
digit_u32(('4'), 4_u32).
digit_u32(('5'), 5_u32).
digit_u32(('6'), 6_u32).
digit_u32(('7'), 7_u32).
digit_u32(('8'), 8_u32).
digit_u32(('9'), 9_u32).

:- pred is_not_digit(char).
:- mode is_not_digit(in) is semidet.
is_not_digit(C) :-
  not is_digit(C).

:- pred is_not_alnum_nor_minus(char).
:- mode is_not_alnum_nor_minus(in) is semidet.
is_not_alnum_nor_minus(C) :-
  not (is_alnum(C); C = ('-')).

:- pred det_string_to_uint32(string, uint32).
:- mode det_string_to_uint32(in, out) is det.
det_string_to_uint32(S, U) :-
  to_char_list(S) = CL,
  (if (det_string_to_uint32_loop(CL, 0_u32, U1))
   then (U = U1)
   else throw("cannot convert string to uint32")).

:- pred det_string_to_uint32_loop(list(char), uint32, uint32).
:- mode det_string_to_uint32_loop(in, in, out) is semidet.
det_string_to_uint32_loop([], U0, U1) :- U1 = U0.
det_string_to_uint32_loop([C | Tail], U0, U1) :-
  digit_u32(C, Digit),
  det_string_to_uint32_loop(Tail, (U0 * 10_u32) + Digit, U1).

:- pred det_signed_string_to_uint32(string, uint32).
:- mode det_signed_string_to_uint32(in, out) is det.
det_signed_string_to_uint32(S, U) :-
  if prefix(S, "-")
  then (det_remove_prefix("-", S, S1),
        det_string_to_uint32(S1, U1),
        U = twos_cmp(U1))
  else det_string_to_uint32(S, U).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Parsing the "assembly" language.
%%%

:- func opcode_halt  = uint8.
:- func opcode_add   = uint8.
:- func opcode_sub   = uint8.
:- func opcode_mul   = uint8.
:- func opcode_div   = uint8.
:- func opcode_mod   = uint8.
:- func opcode_lt    = uint8.
:- func opcode_gt    = uint8.
:- func opcode_le    = uint8.
:- func opcode_ge    = uint8.
:- func opcode_eq    = uint8.
:- func opcode_ne    = uint8.
:- func opcode_and   = uint8.
:- func opcode_or    = uint8.
:- func opcode_neg   = uint8.
:- func opcode_not   = uint8.
:- func opcode_prtc  = uint8.
:- func opcode_prti  = uint8.
:- func opcode_prts  = uint8.
:- func opcode_fetch = uint8.
:- func opcode_store = uint8.
:- func opcode_push  = uint8.
:- func opcode_jmp   = uint8.
:- func opcode_jz    = uint8.
opcode_halt  = 0_u8.
opcode_add   = 1_u8.
opcode_sub   = 2_u8.
opcode_mul   = 3_u8.
opcode_div   = 4_u8.
opcode_mod   = 5_u8.
opcode_lt    = 6_u8.
opcode_gt    = 7_u8.
opcode_le    = 8_u8.
opcode_ge    = 9_u8.
opcode_eq    = 10_u8.
opcode_ne    = 11_u8.
opcode_and   = 12_u8.
opcode_or    = 13_u8.
opcode_neg   = 14_u8.
opcode_not   = 15_u8.
opcode_prtc  = 16_u8.
opcode_prti  = 17_u8.
opcode_prts  = 18_u8.
opcode_fetch = 19_u8.
opcode_store = 20_u8.
opcode_push  = 21_u8.
opcode_jmp   = 22_u8.
opcode_jz    = 23_u8.

:- pred opcode(string, uint8).
:- mode opcode(in, out) is semidet.
%:- mode opcode(out, in) is semidet.  <-- Not needed.
opcode("halt",  opcode_halt).
opcode("add",   opcode_add).
opcode("sub",   opcode_sub).
opcode("mul",   opcode_mul).
opcode("div",   opcode_div).
opcode("mod",   opcode_mod).
opcode("lt",    opcode_lt).
opcode("gt",    opcode_gt).
opcode("le",    opcode_le).
opcode("ge",    opcode_ge).
opcode("eq",    opcode_eq).
opcode("ne",    opcode_ne).
opcode("and",   opcode_and).
opcode("or",    opcode_or).
opcode("neg",   opcode_neg).
opcode("not",   opcode_not).
opcode("prtc",  opcode_prtc).
opcode("prti",  opcode_prti).
opcode("prts",  opcode_prts).
opcode("fetch", opcode_fetch).
opcode("store", opcode_store).
opcode("push",  opcode_push).
opcode("jmp",   opcode_jmp).
opcode("jz",    opcode_jz).

:- pred parse_header(string, uint32, uint32).
:- mode parse_header(in, out, out) is det.
parse_header(S, Datasize, Strings_Count) :-
  % Split S on any non-digit characters, leaving a list of the two
  % runs of digits.
  if (words_separator(is_not_digit, S) = [S_Datasize, S_Strings])
  % Convert the runs of digits to uint32.
  then (det_string_to_uint32(S_Datasize, Datasize),
        det_string_to_uint32(S_Strings, Strings_Count))
  else throw("cannot parse the header").

:- pred parse_string_literal(string, string).
:- mode parse_string_literal(in, out) is det.
parse_string_literal(S0, S) :-
  % Strip leading/trailing space.
  S1 = strip(S0),
  % Remove the " characters.
  det_remove_prefix("\"", S1, S2),
  det_remove_suffix(S2, "\"") = S3,
  % Deal with "\\" and "\n".
  replace_escapes(S3, S).

:- pred replace_escapes(string, string).
:- mode replace_escapes(in, out) is det.
replace_escapes(S0, S) :-
  CL0 = to_char_list(S0),
  replace_escapes(CL0, [], CL),
  S = from_rev_char_list(CL).

:- pred replace_escapes(list(char), list(char), list(char)).
:- mode replace_escapes(in, in, out) is det.
replace_escapes([], Dst0, Dst) :-
  Dst = Dst0.
replace_escapes([C | Tail], Dst0, Dst) :-
  if (C \= ('\\'))
  then replace_escapes(Tail, [C | Dst0], Dst)
  else (if (Tail = [C1 | Tail1])
        then (if (C1 = ('n'))
              then replace_escapes(Tail1, [('\n') | Dst0], Dst)
              else if (C1 = ('\\'))
              then replace_escapes(Tail1, [('\\') | Dst0], Dst)
              else throw("illegal escape sequence"))
        else throw("truncated escape sequence")).

:- pred parse_instruction(string, {uint32, uint8, uint32}).
:- mode parse_instruction(in, out) is det.
parse_instruction(S, {Address, Opcode, Arg}) :-
  words_separator(is_not_alnum_nor_minus, S) = Lst,
  (if parse_instr_lst(Lst, {Addr, Op, A})
   then (Address = Addr, Opcode = Op, Arg = A)
   else throw("cannot parse instruction")).

:- pred parse_instr_lst(list(string), {uint32, uint8, uint32}).
:- mode parse_instr_lst(in, out) is semidet.
parse_instr_lst([S_Address, S_Opcode],
                {Address, Opcode, Arg}) :-
  det_string_to_uint32(S_Address, Address),
  opcode(S_Opcode, Opcode),
  Arg = 0_u32.
parse_instr_lst([S_Address, S_Opcode, S_Arg | _],
                {Address, Opcode, Arg}) :-
  det_string_to_uint32(S_Address, Address),
  opcode(S_Opcode, Opcode),
  det_signed_string_to_uint32(S_Arg, Arg).

:- pred parse_assembly((io.text_input_stream), uint32, uint32,
                       array(string),
                       list({uint32, uint8, uint32}),
                       io, io).
:- mode parse_assembly(in, out, out, out, out, di, uo) is det.
parse_assembly(InpF, Datasize, Strings_Count, Strings,
               Instructions, !IO) :-
  read_line_as_string(InpF, Res, !IO),
  (if (Res = ok(Line))
   then (parse_header(Line, Datasize, Strings_Count),
         read_and_parse_strings(InpF, Strings_Count, Strings, !IO),
         read_and_parse_instructions(InpF, Instructions, !IO))
   else if (Res = eof)
   then throw("empty input")
   else throw("read error")).

:- pred read_and_parse_strings((io.text_input_stream), uint32,
                               array(string), io, io).
:- mode read_and_parse_strings(in, in, out, di, uo) is det.
read_and_parse_strings(InpF, Strings_Count, Strings, !IO) :-
  read_n_string_literals(InpF, Strings_Count, [], Lst, !IO),
  Strings = array(Lst).

:- pred read_n_string_literals((io.text_input_stream), uint32,
                               list(string), list(string),
                               io, io).
:- mode read_n_string_literals(in, in, in, out, di, uo) is det.
read_n_string_literals(InpF, N, Lst0, Lst, !IO) :-
  if (N = 0_u32)
  then (Lst = reverse(Lst0))
  else (read_line_as_string(InpF, Res, !IO),
        (if (Res = ok(Line))
         then (parse_string_literal(Line, S),
               read_n_string_literals(InpF, N - 1_u32,
                                      [S | Lst0], Lst, !IO))
         else if (Res = eof)
         then throw("premature end of input")
         else throw("read error"))).

:- pred read_and_parse_instructions((io.text_input_stream),
                                    list({uint32, uint8, uint32}),
                                    io, io).
:- mode read_and_parse_instructions(in, out, di, uo) is det.
read_and_parse_instructions(InpF, Instructions, !IO) :-
  read_all_instructions(InpF, [], Instructions, !IO).

:- pred read_all_instructions((io.text_input_stream),
                              list({uint32, uint8, uint32}),
                              list({uint32, uint8, uint32}),
                              io, io).
:- mode read_all_instructions(in, in, out, di, uo) is det.
read_all_instructions(InpF, Lst0, Lst, !IO) :-
  read_line_as_string(InpF, Res, !IO),
  (if (Res = eof)
   then (Lst = Lst0)           % There is no need to reverse the list.
   else if (Res = ok(Line))
   then (strip(Line) = S,
         (if is_empty(S)
          then read_all_instructions(InpF, Lst0, Lst, !IO)
          else (parse_instruction(S, Instr),
                read_all_instructions(InpF, [Instr | Lst0], Lst,
                                      !IO))))
   else throw("read error")).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Constructing the executable memory.
%%%

:- func greatest_address(list({uint32, uint8, uint32}),
                         uint32) = uint32.
:- mode greatest_address(in, in) = out is det.
greatest_address([], Min_Result) = Result :-
  Result = Min_Result.
greatest_address([{Addr, _, _} | Tail], Min_Result) = Result :-
  if (Min_Result < Addr)
  then (Result = greatest_address(Tail, Addr))
  else (Result = greatest_address(Tail, Min_Result)).

:- pred executable_memory(list({uint32, uint8, uint32}),
                          array(uint8)).
:- mode executable_memory(in, out) is det.
executable_memory(Instructions, Code) :-
  greatest_address(Instructions, 0_u32) = Addr,
  Code_Size = (Addr + 5_u32),   % At least enough memory.
  init(cast_to_int(Code_Size), opcode_halt, Code0),
  fill_executable_memory(Instructions, Code0, Code).

:- pred fill_executable_memory(list({uint32, uint8, uint32}),
                               array(uint8), array(uint8)).
:- mode fill_executable_memory(in, array_di, array_uo) is det.
fill_executable_memory([], !Code) :- true.
fill_executable_memory([Instr | Tail], !Code) :-
  Instr = {Address, Opcode, Arg},
  Addr = cast_to_int(Address),
  set(Addr, Opcode, !Code),
  (if (Opcode = opcode_fetch;
       Opcode = opcode_store;
       Opcode = opcode_push;
       Opcode = opcode_jmp;
       Opcode = opcode_jz)
   then (to_bytes(Arg, B3, B2, B1, B0),
         % Store the argument in big-endian order.
         set(Addr + 1, B3, !Code),
         set(Addr + 2, B2, !Code),
         set(Addr + 3, B1, !Code),
         set(Addr + 4, B0, !Code))
   else true),
  fill_executable_memory(Tail, !Code).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%e
%%%
%%% Executing the code.
%%%

:- pred machine_add(array(uint32), array(uint32), uint32, uint32).
:- mode machine_add(array_di, array_uo, in, out) is det.
:- pragma inline(machine_add/4).
machine_add(Stack0, Stack, SP0, SP) :-
  Result = unsigned_add(lookup(Stack0, cast_to_int(SP - 1_u32)),
                        lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_sub(array(uint32), array(uint32), uint32, uint32).
:- mode machine_sub(array_di, array_uo, in, out) is det.
:- pragma inline(machine_sub/4).
machine_sub(Stack0, Stack, SP0, SP) :-
  Result = unsigned_sub(lookup(Stack0, cast_to_int(SP - 1_u32)),
                        lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_mul(array(uint32), array(uint32), uint32, uint32).
:- mode machine_mul(array_di, array_uo, in, out) is det.
:- pragma inline(machine_mul/4).
machine_mul(Stack0, Stack, SP0, SP) :-
  Result = signed_mul(lookup(Stack0, cast_to_int(SP - 1_u32)),
                      lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_div(array(uint32), array(uint32), uint32, uint32).
:- mode machine_div(array_di, array_uo, in, out) is det.
:- pragma inline(machine_div/4).
machine_div(Stack0, Stack, SP0, SP) :-
  Result = signed_quot(lookup(Stack0, cast_to_int(SP - 1_u32)),
                       lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_mod(array(uint32), array(uint32), uint32, uint32).
:- mode machine_mod(array_di, array_uo, in, out) is det.
:- pragma inline(machine_mod/4).
machine_mod(Stack0, Stack, SP0, SP) :-
  Result = signed_rem(lookup(Stack0, cast_to_int(SP - 1_u32)),
                      lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_lt(array(uint32), array(uint32), uint32, uint32).
:- mode machine_lt(array_di, array_uo, in, out) is det.
:- pragma inline(machine_lt/4).
machine_lt(Stack0, Stack, SP0, SP) :-
  Result = signed_lt(lookup(Stack0, cast_to_int(SP - 1_u32)),
                     lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_le(array(uint32), array(uint32), uint32, uint32).
:- mode machine_le(array_di, array_uo, in, out) is det.
:- pragma inline(machine_le/4).
machine_le(Stack0, Stack, SP0, SP) :-
  Result = signed_le(lookup(Stack0, cast_to_int(SP - 1_u32)),
                     lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_gt(array(uint32), array(uint32), uint32, uint32).
:- mode machine_gt(array_di, array_uo, in, out) is det.
:- pragma inline(machine_gt/4).
machine_gt(Stack0, Stack, SP0, SP) :-
  Result = signed_gt(lookup(Stack0, cast_to_int(SP - 1_u32)),
                     lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_ge(array(uint32), array(uint32), uint32, uint32).
:- mode machine_ge(array_di, array_uo, in, out) is det.
:- pragma inline(machine_ge/4).
machine_ge(Stack0, Stack, SP0, SP) :-
  Result = signed_ge(lookup(Stack0, cast_to_int(SP - 1_u32)),
                     lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_eq(array(uint32), array(uint32), uint32, uint32).
:- mode machine_eq(array_di, array_uo, in, out) is det.
:- pragma inline(machine_eq/4).
machine_eq(Stack0, Stack, SP0, SP) :-
  Result = unsigned_eq(lookup(Stack0, cast_to_int(SP - 1_u32)),
                       lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_ne(array(uint32), array(uint32), uint32, uint32).
:- mode machine_ne(array_di, array_uo, in, out) is det.
:- pragma inline(machine_ne/4).
machine_ne(Stack0, Stack, SP0, SP) :-
  Result = unsigned_ne(lookup(Stack0, cast_to_int(SP - 1_u32)),
                       lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_and(array(uint32), array(uint32), uint32, uint32).
:- mode machine_and(array_di, array_uo, in, out) is det.
:- pragma inline(machine_and/4).
machine_and(Stack0, Stack, SP0, SP) :-
  Result = logical_and(lookup(Stack0, cast_to_int(SP - 1_u32)),
                       lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_or(array(uint32), array(uint32), uint32, uint32).
:- mode machine_or(array_di, array_uo, in, out) is det.
:- pragma inline(machine_or/4).
machine_or(Stack0, Stack, SP0, SP) :-
  Result = logical_or(lookup(Stack0, cast_to_int(SP - 1_u32)),
                      lookup(Stack0, cast_to_int(SP))),
  set(cast_to_int(SP - 1_u32), Result, Stack0, Stack),
  SP = SP0 - 1_u32.

:- pred machine_neg(array(uint32), array(uint32), uint32, uint32).
:- mode machine_neg(array_di, array_uo, in, out) is det.
:- pragma inline(machine_neg/4).
machine_neg(Stack0, Stack, SP0, SP) :-
  SP = SP0,
  (I = uint32.cast_to_int(SP0)),
  Result = twos_cmp(lookup(Stack0, I - 1)),
  set(I - 1, Result, Stack0, Stack).

:- pred machine_not(array(uint32), array(uint32), uint32, uint32).
:- mode machine_not(array_di, array_uo, in, out) is det.
:- pragma inline(machine_not/4).
machine_not(Stack0, Stack, SP0, SP) :-
  SP = SP0,
  (I = uint32.cast_to_int(SP0)),
  Result = logical_cmp(lookup(Stack0, I - 1)),
  set(I - 1, Result, Stack0, Stack).

:- pred machine_prtc((io.text_output_stream),
                     array(uint32), array(uint32),
                     uint32, uint32, io, io).
:- mode machine_prtc(in, array_di, array_uo, in, out,
                     di, uo) is det.
machine_prtc(OutF, Stack0, Stack, SP0, SP, !IO) :-
  Stack = Stack0,
  (I = uint32.cast_to_int(SP0)),
  X = lookup(Stack0, I - 1),
  C = (char.det_from_int(uint32.cast_to_int(X))),
  (io.write_char(OutF, C, !IO)),
  SP = SP0 - 1_u32.

:- pred machine_prti((io.text_output_stream),
                     array(uint32), array(uint32),
                     uint32, uint32, io, io).
:- mode machine_prti(in, array_di, array_uo, in, out,
                     di, uo) is det.
machine_prti(OutF, Stack0, Stack, SP0, SP, !IO) :-
  Stack = Stack0,
  (I = uint32.cast_to_int(SP0)),
  (X = int32.cast_from_uint32(lookup(Stack0, I - 1))),
  (io.write_int32(OutF, X, !IO)),
  SP = SP0 - 1_u32.

:- pred machine_prts((io.text_output_stream),
                     array(string),
                     array(uint32), array(uint32),
                     uint32, uint32, io, io).
:- mode machine_prts(in, in, array_di, array_uo, in, out,
                     di, uo) is det.
machine_prts(OutF, Strings, Stack0, Stack, SP0, SP, !IO) :-
  Stack = Stack0,
  (I = uint32.cast_to_int(SP0)),
  (K = uint32.cast_to_int(lookup(Stack0, I - 1))),
  S = lookup(Strings, K),
  (io.write_string(OutF, S, !IO)),
  SP = SP0 - 1_u32.

:- func get_immediate(array(uint8), uint32) = uint32.
:- mode get_immediate(in, in) = out is det.
:- pragma inline(get_immediate/2).
get_immediate(Code, IP) = Immediate_Value :-
  % Big-endian order.
  I = cast_to_int(IP),
  B3 = lookup(Code, I),
  B2 = lookup(Code, I + 1),
  B1 = lookup(Code, I + 2),
  B0 = lookup(Code, I + 3),
  Immediate_Value = from_bytes_be(B3, B2, B1, B0).

:- pred machine_fetch(array(uint32), array(uint32),
                      array(uint8), uint32, uint32,
                      array(uint32), array(uint32),
                      uint32, uint32).
:- mode machine_fetch(array_di, array_uo, in, in, out,
                      array_di, array_uo, in, out) is det.
:- pragma inline(machine_fetch/9).
machine_fetch(Data0, Data, Code, IP0, IP, !Stack, SP0, SP) :-
  Data = Data0,
  K = get_immediate(Code, IP0),
  IP = IP0 + 4_u32,
  X = lookup(Data0, cast_to_int(K)),
  set(cast_to_int(SP0), X, !Stack),
  SP = SP0 + 1_u32.

:- pred machine_store(array(uint32), array(uint32),
                      array(uint8), uint32, uint32,
                      array(uint32), array(uint32),
                      uint32, uint32).
:- mode machine_store(array_di, array_uo, in, in, out,
                      array_di, array_uo, in, out) is det.
:- pragma inline(machine_store/9).
machine_store(!Data, Code, IP0, IP, Stack0, Stack, SP0, SP) :-
  Stack = Stack0,
  K = get_immediate(Code, IP0),
  IP = IP0 + 4_u32,
  SP = SP0 - 1_u32,
  X = lookup(Stack0, cast_to_int(SP)),
  set(cast_to_int(K), X, !Data).

:- pred machine_push(array(uint8), uint32, uint32,
                     array(uint32), array(uint32),
                     uint32, uint32).
:- mode machine_push(in, in, out, array_di, array_uo, in, out) is det.
:- pragma inline(machine_push/7).
machine_push(Code, IP0, IP, !Stack, SP0, SP) :-
  X = get_immediate(Code, IP0),
  IP = IP0 + 4_u32,
  set(cast_to_int(SP0), X, !Stack),
  SP = SP0 + 1_u32.

:- pred machine_jmp(array(uint8), uint32, uint32).
:- mode machine_jmp(in, in, out) is det.
:- pragma inline(machine_jmp/3).
machine_jmp(Code, IP0, IP) :-
  Offset = get_immediate(Code, IP0),
  IP = unsigned_add(IP0, Offset).

:- pred machine_jz(array(uint8), uint32, uint32,
                   array(uint32), array(uint32),
                   uint32, uint32).
:- mode machine_jz(in, in, out, array_di, array_uo, in, out) is det.
:- pragma inline(machine_jz/7).
machine_jz(Code, IP0, IP, Stack0, Stack, SP0, SP) :-
  Stack = Stack0,
  SP = SP0 - 1_u32,
  X = lookup(Stack0, cast_to_int(SP)),
  (if (X = 0_u32)
   then (Offset = get_immediate(Code, IP0),
         IP = unsigned_add(IP0, Offset))
   else (IP = IP0 + 4_u32)).

:- pred run_one_instruction((io.text_output_stream),
                            array(string),
                            array(uint32), array(uint32),
                            array(uint8), uint32, uint32,
                            array(uint32), array(uint32),
                            uint32, uint32, bool, io, io).
:- mode run_one_instruction(in, in, array_di, array_uo,
                            in, in, out, array_di, array_uo,
                            in, out, out, di, uo) is det.
run_one_instruction(OutF, Strings, !Data,
                    Code, IP0, IP, !Stack, !SP,
                    Halt, !IO) :-
  %
  % In the following implementation, any unrecognized instruction
  % causes a HALT, just as an actual "halt" opcode would.
  %
  Opcode = lookup(Code, cast_to_int(IP0)),
  IP1 = IP0 + 1_u32,
  I = (Opcode >> 2),
  J = (Opcode /\ 0x03_u8),
  (if (I = 0_u8)
   then (IP = IP1,
         (if (J = 0_u8)
          then (Halt = yes)
          else if (J = 1_u8)
          then (machine_add(!Stack, !SP),
                Halt = no)
          else if (J = 2_u8)
          then (machine_sub(!Stack, !SP),
                Halt = no)
          else (machine_mul(!Stack, !SP),
                Halt = no)))
   else if (I = 1_u8)
   then (Halt = no,
         IP = IP1,
         (if (J = 0_u8)
          then machine_div(!Stack, !SP)
          else if (J = 1_u8)
          then machine_mod(!Stack, !SP)
          else if (J = 2_u8)
          then machine_lt(!Stack, !SP)
          else machine_gt(!Stack, !SP)))
   else if (I = 2_u8)
   then (Halt = no,
         IP = IP1,
         (if (J = 0_u8)
          then machine_le(!Stack, !SP)
          else if (J = 1_u8)
          then machine_ge(!Stack, !SP)
          else if (J = 2_u8)
          then machine_eq(!Stack, !SP)
          else machine_ne(!Stack, !SP)))
   else if (I = 3_u8)
   then (Halt = no,
         IP = IP1,
         (if (J = 0_u8)
          then machine_and(!Stack, !SP)
          else if (J = 1_u8)
          then machine_or(!Stack, !SP)
          else if (J = 2_u8)
          then machine_neg(!Stack, !SP)
          else machine_not(!Stack, !SP)))
   else if (I = 4_u8)
   then (Halt = no,
         (if (J = 0_u8)
          then (machine_prtc(OutF, !Stack, !SP, !IO),
                IP = IP1)
          else if (J = 1_u8)
          then (machine_prti(OutF, !Stack, !SP, !IO),
                IP = IP1)
          else if (J = 2_u8)
          then (machine_prts(OutF, Strings, !Stack, !SP, !IO),
                IP = IP1)
          else machine_fetch(!Data, Code, IP1, IP, !Stack, !SP)))
   else if (I = 5_u8)
   then (Halt = no,
         (if (J = 0_u8)
          then machine_store(!Data, Code, IP1, IP, !Stack, !SP)
          else if (J = 1_u8)
          then machine_push(Code, IP1, IP, !Stack, !SP)
          else if (J = 2_u8)
          then machine_jmp(Code, IP1, IP)
          else machine_jz(Code, IP1, IP, !Stack, !SP)))
   else (Halt = yes, IP = IP1)).

:- pred run_program((io.text_output_stream), array(string),
                    array(uint32), array(uint32),
                    array(uint8), uint32, uint32,
                    array(uint32), array(uint32),
                    uint32, uint32, io, io).
:- mode run_program(in, in, array_di, array_uo,
                    in, in, out, array_di, array_uo,
                    in, out, di, uo) is det.
run_program(OutF, Strings, !Data, Code, !IP, !Stack, !SP, !IO) :-
  run_one_instruction(OutF, Strings, !Data, Code, !IP, !Stack, !SP,
                      Halt, !IO),
  (if (Halt = yes)
   then true
   else run_program(OutF, Strings, !Data, Code, !IP, !Stack,
                    !SP, !IO)).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

:- pred open_InpF(text_input_stream, string, io, io).
:- mode open_InpF(out, in, di, uo) is det.
open_InpF(InpF, InpF_filename, !IO) :-
  if (InpF_filename = "-")
  then (InpF = io.stdin_stream)
  else (open_input(InpF_filename, InpF_result, !IO),
        (if (InpF_result = ok(F))
         then (InpF = F)
         else throw("Error: cannot open " ++ InpF_filename ++
                    " for input"))).

:- pred open_OutF(text_output_stream, string, io, io).
:- mode open_OutF(out, in, di, uo) is det.
open_OutF(OutF, OutF_filename, !IO) :-
  if (OutF_filename = "-")
  then (OutF = io.stdout_stream)
  else (open_output(OutF_filename, OutF_result, !IO),
        (if (OutF_result = ok(F))
         then (OutF = F)
         else throw("Error: cannot open " ++ OutF_filename ++
                    " for output"))).

:- pred main_program(string, string, io, io).
:- mode main_program(in, in, di, uo) is det.
main_program(InpF_filename, OutF_filename, !IO) :-
  open_InpF(InpF, InpF_filename, !IO),
  open_OutF(OutF, OutF_filename, !IO),
  parse_assembly(InpF, Datasize, _Strings_Count, Strings,
                 Instructions, !IO),
  (if (InpF_filename = "-")
   then true
   else close_input(InpF, !IO)),
  executable_memory(Instructions, Code),
  init(cast_to_int(Datasize), 0_u32, Data0),
  init(2048, 0_u32, Stack0),    % Stack is 2048 words.
  IP0 = 0_u32,
  SP0 = 0_u32,
  run_program(OutF, Strings, Data0, _Data, Code, IP0, _IP,
              Stack0, _Stack, SP0, _SP, !IO),
  (if (OutF_filename = "-")
   then true
   else close_output(OutF, !IO)).

:- pred usage_error(io, io).
:- mode usage_error(di, uo) is det.
usage_error(!IO) :-
  progname("lex", ProgName, !IO),
  (io.format("Usage: %s [INPUT_FILE [OUTPUT_FILE]]\n",
             [s(ProgName)], !IO)),
  (io.write_string(
        "If INPUT_FILE is \"-\" or not present then standard input is used.\n",
        !IO)),
  (io.write_string(
        "If OUTPUT_FILE is \"-\" or not present then standard output is used.\n",
        !IO)),
  set_exit_status(1, !IO).

main(!IO) :-
  command_line_arguments(Args, !IO),
  (if (Args = [])
   then (InpF_filename = "-",
         OutF_filename = "-",
         main_program(InpF_filename, OutF_filename, !IO))
   else if (Args = [F1])
   then (InpF_filename = F1,
         OutF_filename = "-",
         main_program(InpF_filename, OutF_filename, !IO))
   else if (Args = [F1, F2])
   then (InpF_filename = F1,
         OutF_filename = F2,
         main_program(InpF_filename, OutF_filename, !IO))
   else usage_error(!IO)).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Instructions for GNU Emacs--
%%% local variables:
%%% mode: mercury
%%% prolog-indent-width: 2
%%% end:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


###############################################################################
# measure and plot times
package require Tk
package require struct::list
namespace path ::tcl::mathfunc

proc create_log10_plot {title xlabel ylabel xs ys labels shapes colours} {
    set w [toplevel .[clock clicks]]
    wm title $w $title
    pack [canvas $w.c -background white]
    pack [canvas $w.legend -background white]
    update
    plot_log10 $w.c $w.legend $title $xlabel $ylabel $xs $ys $labels $shapes $colours
    $w.c config -scrollregion [$w.c bbox all]
    update
}

proc plot_log10 {canvas legend title xlabel ylabel xs ys labels shapes colours} {
    global xfac yfac
    set log10_xs [map {_ {log10 $_}} $xs]
    foreach series $ys {
        lappend log10_ys [map {_ {log10 $_}} $series]
    }
    set maxx [max {*}$log10_xs]
    set yvalues [lsort -real [struct::list flatten $log10_ys]]
    set firstInf [lsearch $yvalues Inf]
    set maxy [lindex $yvalues [expr {$firstInf == -1 ? [llength $yvalues] - 1 : $firstInf - 1}]]

    set xfac [expr {[winfo width $canvas] * 0.8/$maxx}]
    set yfac [expr {[winfo height $canvas] * 0.8/$maxy}]

    scale $canvas x 0 $maxx $xfac "log10($xlabel)"
    scale $canvas y 0 $maxy $yfac "log10($ylabel)" $maxx $xfac

    $legend create text 30 0 -text $title -anchor nw
    set count 1
    foreach series $log10_ys shape $shapes colour $colours label $labels {
        plotxy $canvas $log10_xs $series $shape $colour
        legenditem $legend [incr count] $shape $colour $label
    }
}

proc map {lambda list} {
    set res [list]
    foreach item $list {lappend res [apply $lambda $item]}
    return $res
}

proc legenditem {legend pos shape colour label} {
    set y [expr {$pos * 15}]
    $shape $legend 20 $y -fill $colour
    $legend create text 30 $y -text $label -anchor w
}

# The actual plotting engine
proc plotxy {canvas _xs _ys shape colour} {
    global xfac yfac
    foreach x $_xs y $_ys {
        if {$y < Inf} {
            lappend xs $x
            lappend ys $y
        }
    }
    set coords [list]
    foreach x $xs y $ys {
        set coord_x [expr {$x*$xfac}]
        set coord_y [expr {-$y*$yfac}]
        $shape $canvas $coord_x $coord_y -fill $colour
        lappend coords $coord_x $coord_y
    }
    $canvas create line $coords -smooth true
}
# Rescales the contents of the given canvas
proc scale {canvas direction from to fac label {other_to 0} {other_fac 0}} {
    set f [expr {$from*$fac}]
    set t [expr {$to*$fac}]
    switch -- $direction {
        x {
            set f [expr {$from * $fac}]
            set t [expr {$to * $fac}]
            # create x-axis
            $canvas create line $f 0 $t 0
            $canvas create text $f 0 -anchor nw -text $from
            $canvas create text $t 0 -anchor n -text [format "%.1f" $to]
            $canvas create text [expr {($f+$t)/2}] 0 -anchor n -text $label

        }
        y {
            set f [expr {$from * -$fac}]
            set t [expr {$to * -$fac}]
            # create y-axis
            $canvas create line 0 $f 0 $t
            $canvas create text 0 $f -anchor se -text $from
            $canvas create text 0 $t -anchor e -text [format "%.1f" $to]
            $canvas create text 0 [expr {($f+$t)/2}] -anchor e -text $label
            # create gridlines
            set xmax [expr {$other_to * $other_fac}]
            for {set i 1} {$i < $to} {incr i} {
                set y [expr {$i * -$fac}]
                $canvas create line 0 $y $xmax $y -dash .
            }
        }
    }
}
# Helper to make points, which are otherwise not a native item type
proc dot {canvas x y args} {
    set id [$canvas create oval [expr {$x-3}] [expr {$y-3}] \
                [expr {$x+3}] [expr {$y+3}]]
    $canvas itemconfigure $id {*}$args
}
proc square {canvas x y args} {
    set id [$canvas create rectangle [expr {$x-3}] [expr {$y-3}] \
                [expr {$x+3}] [expr {$y+3}]]
    $canvas itemconfigure $id {*}$args
}
proc cross {canvas x y args} {
    set l1 [$canvas create line [expr {$x-3}] $y [expr {$x+3}] $y]
    set l2 [$canvas create line $x [expr {$y-3}] $x [expr {$y+3}]]
    $canvas itemconfigure $l1 {*}$args
    $canvas itemconfigure $l2 {*}$args
}
proc x {canvas x y args} {
    set l1 [$canvas create line [expr {$x-3}] [expr {$y-3}] [expr {$x+3}] [expr {$y+3}]]
    set l2 [$canvas create line [expr {$x+3}] [expr {$y-3}] [expr {$x-3}] [expr {$y+3}]]
    $canvas itemconfigure $l1 {*}$args
    $canvas itemconfigure $l2 {*}$args
}
proc triangleup {canvas x y args} {
    set id [$canvas create polygon $x [expr {$y-4}] \
                [expr {$x+4}] [expr {$y+4}] \
                [expr {$x-4}] [expr {$y+4}]]
    $canvas itemconfigure $id {*}$args
}
proc triangledown {canvas x y args} {
    set id [$canvas create polygon $x [expr {$y+4}] \
                [expr {$x+4}] [expr {$y-4}] \
                [expr {$x-4}] [expr {$y-4}]]
    $canvas itemconfigure $id {*}$args
}

wm withdraw .

#####################################################################
# list creation procedures
proc ones n {
    lrepeat $n 1
}
proc reversed n {
    while {[incr n -1] >= 0} {
        lappend result $n
    }
    return $result
}
proc random n {
    for {set i 0} {$i < $n} {incr i} {
        lappend result [expr {int($n * rand())}]
    }
    return $result
}

set algorithms {lsort quicksort shellsort insertionsort bubblesort mergesort}
set sizes {1 10 100 1000 10000 100000}
set types {ones reversed random}
set shapes {dot square cross triangleup triangledown x}
set colours {red blue black brown yellow black}

# create some lists to be used by all sorting algorithms
array set lists {}
foreach size $sizes {
    foreach type $types {
        set lists($type,$size) [$type $size]
    }
}

set runs 10

# header
fconfigure stdout -buffering none
puts -nonewline [format "%-16s" "list length:"]
foreach size $sizes {
    puts -nonewline [format " %10d" $size]
}
puts ""

# perform the sort timings and output results
foreach type $types {
    puts "\nlist type: $type"
    set times [list]
    foreach algo $algorithms {
        set errs [list]
        set thesetimes [list]
        $algo {} ;# call it once to ensure it's compiled

        puts -nonewline [format "   %-13s" $algo]
        foreach size $sizes {
            # some implementations are just too slow
            if {$type ne "ones" && (
                ($algo eq "insertionsort" && $size > 10000) ||
                ($algo eq "bubblesort" && $size > 1000))
            } {
                set time Inf
            } else {
                # OK, do it
                if {[catch {time [list $algo $lists($type,$size)] $runs} result] != 0} {
                    set time Inf
                    lappend errs $result
                } else {
                    set time [lindex [split $result] 0]
                }
            }
            lappend thesetimes $time
            puts -nonewline [format " %10s" $time]
        }
        puts ""
        if {[llength $errs] > 0} {
            puts [format "      %s" [join $errs "\n      "]]
        }
        lappend times $thesetimes
    }
    create_log10_plot "Sorting a '$type' list" size time $sizes $times $algorithms $shapes $colours
}
puts "\ntimes in microseconds, average of $runs runs"


# returns text commatized according to the rules of the task and the      #
#         period, location and separator paramters                        #
PROC commatize = ( STRING text, INT location, INT period, STRING separator )STRING:
     IF  STRING str := text[ AT 1 ];
         # handle the options                                             #
         INT    start position   := IF location  = 0  THEN  1  ELSE location  FI;
         INT    period length    := IF period    = 0  THEN  3  ELSE period    FI;
         STRING separator string := IF separator = "" THEN "," ELSE separator FI;
         period length < 1 OR start position < 1 OR start position > UPB str
     THEN
         # invalid parameters - return the text unchanged                 #
         text
     ELIF # attempt to find a non-zero digit                              #
          INT number pos := start position;
          WHILE IF number pos > UPB str
                THEN FALSE
                ELSE str[ number pos ] < "1" OR str[ number pos ] > "9"
                FI
          DO
              number pos +:= 1
          OD;
          number pos > UPB str
     THEN # no digits in the string - return the text unchanged           #
          text
     ELSE # have at least one digit                                       #
          STRING result := str[ 1 : number pos - 1 ];
          # find the final digit                                          #
          INT number end := number pos;
          WHILE IF number end >= UPB str
                THEN FALSE
                ELSE str[ number end + 1 ] >= "0" AND str[ number end + 1 ] <= "9"
                FI
          DO
              number end +:= 1
          OD;
          # copy the digits commatizing as required                       #
          INT   digit count := ( number end - number pos ) + 1;
          WHILE digit count > 1 DO
              result      +:= str[ number pos ];
              number pos  +:= 1;
              digit count -:= 1;
              IF digit count MOD period length = 0 THEN
                  # need a comma after this digit                         #
                  result +:= separator string
              FI
          OD;
          # final digit and the rest of the string                        #
          result +:= str[ number pos : ];
          result
     FI # commatize # ;

# modes and operators to allow us to specify optional parameters to the   #
# commatizing procedure                                                   #
MODE COMMATIZINGOPTIONS = STRUCT( STRING text, INT location, INT period, STRING separator );
PRIO LOCATION  = 9;
OP   LOCATION  = ( STRING text, INT location )COMMATIZINGOPTIONS:     COMMATIZINGOPTIONS( text, location, 0, "" );
PRIO PERIOD    = 9;
OP   PERIOD    = ( STRING text, INT period   )COMMATIZINGOPTIONS:     COMMATIZINGOPTIONS( text, 0, period, "" );
PRIO SEPARATOR = 9;
OP   SEPARATOR = ( STRING text, CHAR   separator )COMMATIZINGOPTIONS: COMMATIZINGOPTIONS( text, 0, 0, separator );
OP   SEPARATOR = ( STRING text, STRING separator )COMMATIZINGOPTIONS: COMMATIZINGOPTIONS( text, 0, 0, separator );
OP   LOCATION  = ( COMMATIZINGOPTIONS opts, INT location     )COMMATIZINGOPTIONS:
                 COMMATIZINGOPTIONS( text OF opts, location, period OF opts, separator OF opts );
OP   PERIOD    = ( COMMATIZINGOPTIONS opts, INT period       )COMMATIZINGOPTIONS:
                 COMMATIZINGOPTIONS( text OF opts, location OF opts, period, separator OF opts );
OP   SEPARATOR = ( COMMATIZINGOPTIONS opts, CHAR   separator )COMMATIZINGOPTIONS:
                 COMMATIZINGOPTIONS( text OF opts, location OF opts, period OF opts, separator );
OP   SEPARATOR = ( COMMATIZINGOPTIONS opts, STRING separator )COMMATIZINGOPTIONS:
                 COMMATIZINGOPTIONS( text OF opts, location OF opts, period OF opts, separator );
OP   COMMATIZE = ( STRING text             )STRING: commatize( text, 0, 0, "" );
OP   COMMATIZE = ( COMMATIZINGOPTIONS opts )STRING:
                 commatize( text OF opts, location OF opts, period OF opts, separator OF opts );

# test the commatization procedure and operators                          #
print( ( COMMATIZE( "pi=3.14159265358979323846264338327950288419716939937510582097494459231" PERIOD 5 SEPARATOR " " LOCATION 6 ),
                                                                                newline ) );
print( ( COMMATIZE( "The author has two Z$100000000000000 Zimbabwe notes (100 trillion)."             SEPARATOR "." ), newline ) );
print( ( COMMATIZE  """-in Aus$+1411.8millions""",                                                                     newline ) );
print( ( COMMATIZE  "===US$0017440 millions=== (in 2000 dollars)",                                                     newline ) );
print( ( COMMATIZE  "123.e8000 is pretty big.",                                                                        newline ) );
print( ( COMMATIZE  "The land area of the earth is 57268900(29% of the surface) square miles.",                        newline ) );
print( ( COMMATIZE  "Ain't no numbers in this here words, nohow, no way, Jose.",                                       newline ) );
print( ( COMMATIZE  "James was never known as 0000000007",                                                             newline ) );
print( ( COMMATIZE  "Arthur Eddington wrote: I believe there are 15747724136275002577605653961181555468044717914527116709366231425076185631031296 protons in the universe.",
                                                                                newline ) );
print( ( COMMATIZE  "   $-140000±100 millions.",                                                                       newline ) );
print( ( COMMATIZE  "6/9/1946 was a good year for some.",                                                              newline ) )


import os, parseutils, strutils, strscans, strformat

type

  Value = int32
  BytesValue = array[4, byte]
  Address = int32

  OpCode = enum
           opFetch = "fetch"
           opStore = "store"
           opPush = "push"
           opJmp = "jmp"
           opJz = "jz"
           opAdd = "add"
           opSub = "sub"
           opMul = "mul"
           opDiv = "div"
           opMod = "mod"
           opLt = "lt"
           opgt = "gt"
           opLe = "le"
           opGe = "ge"
           opEq = "eq"
           opNe = "ne"
           opAnd = "and"
           opOr = "or"
           opNeg = "neg"
           opNot = "not"
           opPrtc = "prtc"
           opPrti = "prti"
           opPrts = "prts"
           opHalt = "halt"
           opInvalid = "invalid"

  # Virtual machine description.
  VM = object
    stack: seq[Value]     # Evaluation stack.
    memory: seq[byte]     # Memory to store program.
    data: seq[Value]      # Data storage.
    strings: seq[string]  # String storage.
    pc: Address           # Program counter.

  # Exceptions.
  LoadingError = object of CatchableError
  RuntimeError = object of CatchableError

####################################################################################################
# Running program.

proc checkStackLength(vm: VM; minLength: int) {.inline.} =
  ## Check that evaluation stack contains at least "minLength" elements.
  if vm.stack.len < minLength:
    raise newException(RuntimeError, &"not enough operands on the stack (pc = {vm.pc}).")

#---------------------------------------------------------------------------------------------------

proc getOperand(vm: var VM): Value =
  ## Get a 32 bits operand.

  type Union {.union.} = object
    value: Value
    bytes: BytesValue

  if vm.pc + 4 >= vm.memory.len:
    raise newException(RuntimeError, &"out of memory (pc = {vm.pc}).")

  var aux: Union
  let address = vm.pc + 1
  for idx in 0..3:
    aux.bytes[idx] = vm.memory[address + idx]
  result = aux.value

#---------------------------------------------------------------------------------------------------

proc run(vm: var VM) =
  ## Run a program loaded in VM memory.

  vm.pc = 0

  while true:

    if vm.pc notin 0..vm.memory.high:
      raise newException(RuntimeError, &"out of memory (pc = {vm.pc}).")

    let opcode = OpCode(vm.memory[vm.pc])
    case opcode

    of opFetch, opStore:
      let index = vm.getOperand()
      if index notin 0..vm.data.high:
        raise newException(RuntimeError, &"wrong memory index (pc = {vm.pc}).")
      if opcode == opFetch:
        vm.stack.add(vm.data[index])
      else:
        vm.checkStackLength(1)
        vm.data[index] = vm.stack.pop()
      inc vm.pc, 4

    of opPush:
      let value = vm.getOperand()
      vm.stack.add(value)
      inc vm.pc, 4

    of opJmp:
      let offset = vm.getOperand()
      inc vm.pc, offset

    of opJz:
      let offset = vm.getOperand()
      vm.checkStackLength(1)
      let value = vm.stack.pop()
      inc vm.pc, if value == 0: offset else: 4

    of opAdd..opOr:
      # Two operands instructions.
      vm.checkStackLength(2)
      let op2 = vm.stack.pop()
      let op1 = vm.stack.pop()
      case range[opAdd..opOr](opcode)
      of opAdd:
        vm.stack.add(op1 + op2)
      of opSub:
        vm.stack.add(op1 - op2)
      of opMul:
        vm.stack.add(op1 * op2)
      of opDiv:
        vm.stack.add(op1 div op2)
      of opMod:
        vm.stack.add(op1 mod op2)
      of opLt:
        vm.stack.add(Value(op1 < op2))
      of opgt:
        vm.stack.add(Value(op1 > op2))
      of opLe:
        vm.stack.add(Value(op1 <= op2))
      of opGe:
        vm.stack.add(Value(op1 >= op2))
      of opEq:
        vm.stack.add(Value(op1 == op2))
      of opNe:
        vm.stack.add(Value(op1 != op2))
      of opAnd:
        vm.stack.add(op1 and op2)
      of opOr:
        vm.stack.add(op1 or op2)

    of opNeg..opPrts:
      # One operand instructions.
      vm.checkStackLength(1)
      let op = vm.stack.pop()
      case range[opNeg..opPrts](opcode)
      of opNeg:
        vm.stack.add(-op)
      of opNot:
        vm.stack.add(not op)
      of opPrtc:
        stdout.write(chr(op))
      of opPrti:
        stdout.write(op)
      of opPrts:
        if op notin 0..vm.strings.high:
          raise newException(RuntimeError, &"wrong string index (pc = {vm.pc}).")
        stdout.write(vm.strings[op])

    of opHalt:
      break

    of opInvalid:
      discard   # Not possible.

    inc vm.pc

####################################################################################################
# Loading assembly file.

proc parseHeader(line: string): tuple[dataSize, stringCount: int] =
  ## Parse the header.

  if not line.scanf("Datasize: $s$i $sStrings: $i", result.dataSize, result.stringCount):
    raise newException(LoadingError, "Wrong header in code.")

#---------------------------------------------------------------------------------------------------

import re

proc parseString(line: string; linenum: int): string =
  ## Parse a string.

  if not line.startsWith('"'):
    raise newException(LoadingError, "Line $1: incorrect string.".format(linenum))
  # Can't use "unescape" as it is confused by "\\n" and "\n".
  result = line.replacef(re"([^\\])(\\n)", "$1\n").replace(r"\\", r"\").replace("\"", "")

#---------------------------------------------------------------------------------------------------

proc parseValue(line: string; linenum: int; pos: var int; msg: string): int32 =
  ## Parse an int32 value.

  var value: int

  pos += line.skipWhitespace(pos)
  let parsed = line.parseInt(value, pos)
  if parsed == 0:
    raise newException(LoadingError, "Line $1: ".format(linenum) & msg)
  pos += parsed
  result = int32(value)

#---------------------------------------------------------------------------------------------------

proc parseOpcode(line: string; linenum: int; pos: var int): OpCode =
  ## Parse an opcode.

  var opstring: string

  pos += line.skipWhitespace(pos)
  let parsed = line.parseIdent(opstring, pos)
  if parsed == 0:
    raise newException(LoadingError, "Line $1: opcode expected".format(linenum))
  pos += parsed

  result = parseEnum[OpCode](opstring, opInvalid)
  if result == opInvalid:
    raise newException(LoadingError, "Line $1: invalid opcode encountered".format(linenum))

#---------------------------------------------------------------------------------------------------

proc parseMemoryIndex(line: string; linenum: int; pos: var int): int32 =
  ## Parse a memory index (int32 value between brackets).

  var memIndex: int

  pos += line.skipWhitespace(pos)
  let str = line.captureBetween('[', ']', pos)
  if str.parseInt(memIndex) == 0 or memIndex < 0:
    raise newException(LoadingError, "Line $1: invalid memory index".format(lineNum))
  pos += str.len + 2
  result = int32(memIndex)

#---------------------------------------------------------------------------------------------------

proc parseOffset(line: string; linenum: int; pos: var int): int32 =
  ## Parse an offset (int32 value between parentheses).

  var offset: int

  pos += line.skipWhitespace(pos)
  let str = line.captureBetween('(', ')', pos)
  if str.parseInt(offset) == 0:
    raise newException(LoadingError, "Line $1: invalid offset".format(linenum))
  pos += str.len + 2
  result = int32(offset)

#---------------------------------------------------------------------------------------------------

proc load(vm: var VM; code: string) =
  ## Load an assembly code into VM memory.

  # Analyze header.
  let lines = code.splitlines()
  let (dataSize, stringCount) = parseHeader(lines[0])
  vm.data.setLen(dataSize)
  vm.strings.setLen(stringCount)

  # Load strings.
  for idx in 1..stringCount:
    vm.strings[idx - 1] = lines[idx].parseString(idx + 1)

  # Load code.
  var pc: Address = 0
  for idx in (stringCount + 1)..lines.high:
    var pos = 0
    let line = lines[idx]
    if line.len == 0: continue

    # Process address.
    let address = line.parseValue(idx + 1, pos, "address expected")
    if address != pc:
      raise newException(LoadingError, "Line $1: wrong address".format(idx + 1))

    # Process opcode.
    let opcode = line.parseOpcode(idx + 1, pos)
    vm.memory.add(byte(opcode))

    # Process operand.
    case opcode

    of opFetch, opStore:
      # Find memory index.
      let memIndex = line.parseMemoryIndex(idx + 1, pos)
      vm.memory.add(cast[BytesValue](Value(memIndex)))
      inc pc, 5

    of opJmp, opJz:
      # Find offset.
      let offset = line.parseOffset(idx + 1, pos)
      vm.memory.add(cast[BytesValue](Value(offset)))
      # Find and check branch address.
      let branchAddress = line.parseValue(idx + 1, pos, "branch address expected")
      if branchAddress != pc + offset + 1:
        raise newException(LoadingError, "Line $1: wrong branch address".format(idx + 1))
      inc pc, 5

    of opPush:
      # Find value.
      let value = line.parseValue(idx + 1, pos, "value expected")
      vm.memory.add(cast[BytesValue](Value(value)))
      inc pc, 5

    else:
      inc pc

#———————————————————————————————————————————————————————————————————————————————————————————————————

let code = if paramCount() == 0: stdin.readAll() else: paramStr(1).readFile()
var vm: VM

vm.load(code)
vm.run()


import "random" for Random
import "/sort" for Sort
import "/fmt" for Fmt

var rand = Random.new()

var onesSeq = Fn.new { |n| List.filled(n, 1) }

var shuffledSeq = Fn.new { |n|
    var seq = List.filled(n, 0)
    for (i in 0...n) seq[i] = 1 + rand.int(10 * n)
    return seq
}

var ascendingSeq = Fn.new { |n|
    var seq = shuffledSeq.call(n)
    seq.sort()
    return seq
}

var bubbleSort = Fn.new { |a|
    var n = a.count
    while (true) {
        var n2 = 0
        for (i in 1...n) {
            if (a[i - 1] > a[i]) {
                a.swap(i, i - 1)
                n2 = i
            }
        }
        n = n2
        if (n == 0) break
    }
}

// counting sort of 'a' according to the digit represented by 'exp'
var countSort = Fn.new { |a, exp|
    var n = a.count
    var output = [0] * n
    var count  = [0] * 10
    for (i in 0...n) {
        var t = (a[i]/exp).truncate % 10
        count[t] = count[t] + 1
    }
    for (i in 1..9) count[i] = count[i] + count[i-1]
    for (i in n-1..0) {
        var t = (a[i]/exp).truncate % 10
        output[count[t] - 1] = a[i]
        count[t] = count[t] - 1
    }
    for (i in 0...n) a[i] = output[i]
}

// sorts 'a' in place
var radixSort = Fn.new { |a|
    // check for negative elements
    var min = a.reduce { |m, i| (i < m) ? i : m }
    // if there are any, increase all elements by -min
    if (min < 0) (0...a.count).each { |i| a[i] = a[i] - min }
    // now get the maximum to know number of digits
    var max = a.reduce { |m, i| (i > m) ? i : m }
    // do counting sort for each digit
    var exp = 1
    while ((max/exp).truncate > 0) {
        countSort.call(a, exp)
        exp = exp * 10
    }
    // if there were negative elements, reduce all elements by -min
    if (min < 0) (0...a.count).each { |i| a[i] = a[i] + min }
}

var measureTime = Fn.new { |sort, seq|
    var start = System.clock
    sort.call(seq)
    return ((System.clock - start) * 1e6).round // microseconds
}

var runs = 10
var lengths = [1, 10, 100, 1000, 10000, 50000]
var sorts = [
    bubbleSort,
    Fn.new { |a| Sort.insertion(a) },
    Fn.new { |a| Sort.quick(a) },
    radixSort,
    Fn.new { |a| Sort.shell(a) }
]

var sortTitles = ["Bubble", "Insert", "Quick ", "Radix ", "Shell "]
var seqTitles  = ["All Ones", "Ascending", "Shuffled"]
var totals = List.filled(seqTitles.count, null)
for (i in 0...totals.count) {
    totals[i] = List.filled(sorts.count, null)
    for (j in 0...sorts.count) totals[i][j] = List.filled(lengths.count, 0)
}
var k = 0
for (n in lengths) {
    var seqs = [onesSeq.call(n), ascendingSeq.call(n), shuffledSeq.call(n)]
    for (r in 0...runs) {
        for (i in 0...seqs.count) {
            for (j in 0...sorts.count) {
                var seq = seqs[i].toList
                totals[i][j][k] = totals[i][j][k] + measureTime.call(sorts[j], seq)
            }
        }
    }
    k = k + 1
}
System.print("All timings in microseconds\n")
System.write("Sequence length")
for (len in lengths) Fmt.write("$8d   ", len)
System.print("\n")
for (i in 0...seqTitles.count) {
    System.print("  %(seqTitles[i]):")
    for (j in 0...sorts.count) {
        System.write("    %(sortTitles[j])     ")
        for (k in 0...lengths.count) {
            var time = (totals[i][j][k] / runs).round
            Fmt.write("$8d   ", time)
        }
        System.print()
    }
    System.print("\n")
}


static string[] inputs = {
	"pi=3.14159265358979323846264338327950288419716939937510582097494459231",
	"The author has two Z$100000000000000 Zimbabwe notes (100 trillion).",
	"\"-in Aus$+1411.8millions\"",
	"===US$0017440 millions=== (in 2000 dollars)"
};

void Main()
{
	inputs.Select(s => Commatize(s, 0, 3, ","))
              .ToList()
              .ForEach(Console.WriteLine);
}

string Commatize(string text, int startPosition, int interval, string separator)
{
	var matches = Regex.Matches(text.Substring(startPosition), "[0-9]*");
	var x = matches.Cast<Match>().Select(match => Commatize(match, interval, separator, text)).ToList();
	return string.Join("", x);
}

string Commatize(Match match, int interval, string separator, string original)
{
	if (match.Length <= interval)
		return original.Substring(match.Index,
                match.Index == original.Length ? 0 : Math.Max(match.Length, 1));

	return string.Join(separator, match.Value.Split(interval));
}

public static class Extension
{
	public static string[] Split(this string source, int interval)
	{
		return SplitImpl(source, interval).ToArray();
	}

	static IEnumerable<string>SplitImpl(string source, int interval)
	{
		for	(int i = 1; i < source.Length; i++)
		{
			if (i % interval != 0) continue;

			yield return source.Substring(i - interval, interval);
		}
	}
}


import std.stdio, std.regex, std.range;

auto commatize(in char[] txt, in uint start=0, in uint step=3,
        in string ins=",") @safe
in {
    assert(step > 0);
} body {
    if (start > txt.length || step > txt.length)
        return txt;

    // First number may begin with digit or decimal point. Exponents ignored.
    enum decFloField = ctRegex!("[0-9]*\\.[0-9]+|[0-9]+");

    auto matchDec = matchFirst(txt[start .. $], decFloField);
    if (!matchDec)
        return txt;

    // Within a decimal float field:
    // A decimal integer field to commatize is positive and not after a point.
    enum decIntField = ctRegex!("(?<=\\.)|[1-9][0-9]*");
    // A decimal fractional field is preceded by a point, and is only digits.
    enum decFracField = ctRegex!("(?<=\\.)[0-9]+");

    return txt[0 .. start] ~ matchDec.pre ~ matchDec.hit
        .replace!(m => m.hit.retro.chunks(step).join(ins).retro)(decIntField)
        .replace!(m => m.hit.chunks(step).join(ins))(decFracField)
        ~ matchDec.post;
}

unittest {
    // An attempted solution may have one or more of the following errors:
    //    ignoring a number that has only zero before its decimal point
    assert("0.0123456".commatize == "0.012,345,6");
    //    commatizing numbers other than the first
    assert("1000 2.3000".commatize == "1,000 2.3000");
    //    only commatizing in one direction from the decimal point
    assert("0001123.456789".commatize == "0001,123.456,789");
    //    detecting prefixes such as "Z$" requires detecting other prefixes
    assert(" NZ$300000".commatize == " NZ$300,000");
    //    detecting a decimal field that isn't attached to the first number
    assert(" 2600 and .0125".commatize == " 2,600 and .0125");
    //    ignoring the start value, or confusing base 0 (used here) with base 1
    assert("1 77000".commatize(1) == "1 77,000");
    //    ignoring a number that begins with a point, or treating it as integer
    assert(" .0104004".commatize == " .010,400,4");
}

void main() {
    "pi=3.14159265358979323846264338327950288419716939937510582097494459231"
        .commatize(0, 5, " ").writeln;
    "The author has two Z$100000000000000 Zimbabwe notes (100 trillion)."
        .commatize(0, 3, ".").writeln;
    foreach (const line; "commatizing_numbers_using_defaults.txt".File.byLine)
        line.commatize.writeln;
}


# -*- ObjectIcon -*-
#
# The Rosetta Code virtual machine in Object Icon.
#
# See https://rosettacode.org/wiki/Compiler/virtual_machine_interpreter
#

import io

procedure main(args)
  local f_inp, f_out
  local vm

  if 3 <= *args then {
    write("Usage: ", &progname, " [INPUT_FILE [OUTPUT_FILE]]")
    exit(1)
  }

  if 1 <= *args then {
    f_inp := FileStream(args[1], FileOpt.RDONLY) | stop (&why)
  } else {
    f_inp := FileStream.stdin
  }
  f_inp := BufferStream(f_inp)

  if 2 <= *args then {
    f_out := FileStream(args[2], ior (FileOpt.WRONLY,
                                      FileOpt.TRUNC,
                                      FileOpt.CREAT)) | stop (&why)
  } else {
    f_out := FileStream.stdout
  }

  vm := VirtualMachine()
  vm.read_assembly_code(f_inp)
  vm.run(f_out)
end

procedure int2bytes (n)
  local bytes

  # The VM is little-endian.

  bytes := "****"
  bytes[1] := char (iand(n, 16rFF))
  bytes[2] := char(iand(ishift(n, -8), 16rFF))
  bytes[3] := char(iand(ishift(n, -16), 16rFF))
  bytes[4] := char(iand(ishift(n, -24), 16rFF))
  return bytes
end

procedure bytes2int(bytes, i)
  local n0, n1, n2, n3, n

  # The VM is little-endian.

  n0 := ord(bytes[i])
  n1 := ishift(ord(bytes[i + 1]), 8)
  n2 := ishift(ord(bytes[i + 2]), 16)
  n3 := ishift(ord(bytes[i + 3]), 24)
  n := ior (n0, ior (n1, ior (n2, n3)))

  # Do not forget to extend the sign bit.
  return (if n3 <= 16r7F then n else ior(n, icom(16rFFFFFFFF)))
end

class OpcodeCollection()

  public static const opcode_names
  public static const opcode_values

  public static const op_halt
  public static const op_add
  public static const op_sub
  public static const op_mul
  public static const op_div
  public static const op_mod
  public static const op_lt
  public static const op_gt
  public static const op_le
  public static const op_ge
  public static const op_eq
  public static const op_ne
  public static const op_and
  public static const op_or
  public static const op_neg
  public static const op_not
  public static const op_prtc
  public static const op_prti
  public static const op_prts
  public static const op_fetch
  public static const op_store
  public static const op_push
  public static const op_jmp
  public static const op_jz

  private static init()
    local i

    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"]

    opcode_values := table()
    every i := 1 to *opcode_names do
      opcode_values[opcode_names[i]] := char(i)

    op_halt := opcode_values["halt"]
    op_add := opcode_values["add"]
    op_sub := opcode_values["sub"]
    op_mul := opcode_values["mul"]
    op_div := opcode_values["div"]
    op_mod := opcode_values["mod"]
    op_lt := opcode_values["lt"]
    op_gt := opcode_values["gt"]
    op_le := opcode_values["le"]
    op_ge := opcode_values["ge"]
    op_eq := opcode_values["eq"]
    op_ne := opcode_values["ne"]
    op_and := opcode_values["and"]
    op_or := opcode_values["or"]
    op_neg := opcode_values["neg"]
    op_not := opcode_values["not"]
    op_prtc := opcode_values["prtc"]
    op_prti := opcode_values["prti"]
    op_prts := opcode_values["prts"]
    op_fetch := opcode_values["fetch"]
    op_store := opcode_values["store"]
    op_push := opcode_values["push"]
    op_jmp := opcode_values["jmp"]
    op_jz := opcode_values["jz"]

    return
  end

end

class VirtualMachine(OpcodeCollection)

  public code
  public global_data
  public strings
  public stack
  public pc

  private static const whitespace_chars

  private static init()
    whitespace_chars := ' \t\n\r\f\v'
    return
  end

  public read_assembly_code(f)
    local data_size, number_of_strings
    local line, ch
    local i
    local address
    local opcode

    # Read the header line.
    line := f.read() | bad_vm()
    line ? {
      tab(many(whitespace_chars))
      tab(match("Datasize")) | bad_vm()
      tab(many(whitespace_chars))
      tab(any(':')) | bad_vm()
      tab(many(whitespace_chars))
      data_size :=
        integer(tab(many(&digits))) | bad_vm()
      tab(many(whitespace_chars))
      tab(match("Strings")) | bad_vm()
      tab(many(whitespace_chars))
      tab(any(':')) | bad_vm()
      tab(many(whitespace_chars))
      number_of_strings :=
        integer(tab(many(&digits))) | bad_vm()
    }

    # Read the strings.
    strings := list(number_of_strings)
    every i := 1 to number_of_strings do {
      strings[i] := ""
      line := f.read() | bad_vm()
      line ? {
        tab(many(whitespace_chars))
        tab(any('"')) | bad_vm()
        while ch := tab(any(~'"')) do {
          if ch == '\\' then {
            ch := tab(any('n\\')) | bad_vm()
            strings[i] ||:=
              (if (ch == "n") then "\n" else "\\")
          } else {
            strings[i] ||:= ch
          }
        }
      }
    }

    # Read the code.
    code := ""
    while line := f.read() do {
      line ? {
        tab(many(whitespace_chars))
        address := integer(tab(many(&digits))) | bad_vm()
        tab(many(whitespace_chars))
        opcode := tab(many(~whitespace_chars)) | bad_vm()
        code ||:= opcode_values[opcode]
        case opcode of {
          "push": {
            tab(many(whitespace_chars))
            code ||:=
                int2bytes(integer(tab(many(&digits)))) |
                int2bytes(integer(tab(any('-')) ||
                                  tab(many(&digits)))) |
                bad_vm()
          }
          "fetch" | "store": {
            tab(many(whitespace_chars))
            tab(any('[')) | bad_vm()
            tab(many(whitespace_chars))
            code ||:=
              int2bytes(integer(tab(many(&digits)))) |
              bad_vm()
            tab(many(whitespace_chars))
            tab(any(']')) | bad_vm()
          }
          "jmp" | "jz": {
            tab(many(whitespace_chars))
            tab(any('(')) | bad_vm()
            tab(many(whitespace_chars))
            code ||:=
              int2bytes(integer(tab(many(&digits)))) |
              int2bytes(integer(tab(any('-')) ||
                                tab(many(&digits)))) |
              bad_vm()
            tab(many(whitespace_chars))
            tab(any(')')) | bad_vm()
            tab(many(whitespace_chars))
            tab(many(&digits)) | bad_vm()
          }
          default: {
            # Do nothing
          }
        }
      }
    }

    # Create a global data area.
    global_data := list(data_size, &null)

    initialize()

    return
  end

  public run(f_out)
    initialize()
    continue(f_out)
    return
  end

  public continue(f_out)
    while code[pc] ~== op_halt do
      step(f_out)
  end

  public step(f_out)
    local opcode

    opcode := code[pc]
    pc +:= 1
    case opcode of {
      op_add:   binop("+")
      op_sub:   binop("-")
      op_mul:   binop("*")
      op_div:   binop("/")
      op_mod:   binop("%")
      op_lt:    comparison("<")
      op_gt:    comparison(">")
      op_le:    comparison("<=")
      op_ge:    comparison(">=")
      op_eq:    comparison("=")
      op_ne:    comparison("~=")
      op_and:   logical_and()
      op_or:    logical_or()
      op_neg:   negate()
      op_not:   logical_not()
      op_prtc:  printc(f_out)
      op_prti:  printi(f_out)
      op_prts:  prints(f_out)
      op_fetch: fetch_global()
      op_store: store_global()
      op_push:  push_argument()
      op_jmp:   jump()
      op_jz:    jump_if_zero()
      default:  bad_opcode()
    }
  end

  private negate()
    stack[1] := -stack[1]
    return
  end

  private binop(func)
    stack[2] := func(stack[2], stack[1])
    pop(stack)
    return
  end

  private comparison(func)
    stack[2] := (if func(stack[2], stack[1]) then 1 else 0)
    pop(stack)
    return
  end

  private logical_and()
    stack[2] := (if stack[2] ~= 0 & stack[1] ~= 0 then 1 else 0)
    pop(stack)
    return
  end

  private logical_or()
    stack[2] := (if stack[2] ~= 0 | stack[1] ~= 0 then 1 else 0)
    pop(stack)
    return
  end

  private logical_not()
    stack[1] := (if stack[1] ~= 0 then 0 else 1)
    return
  end

  private printc(f_out)
    /f_out := FileStream.stdout
    f_out.writes(char(pop(stack)))
    return
  end

  private printi(f_out)
    /f_out := FileStream.stdout
    f_out.writes(pop(stack))
    return
  end

  private prints(f_out)
    /f_out := FileStream.stdout
    f_out.writes(strings[pop(stack) + 1])
    return
  end

  private fetch_global()
    push(stack, global_data[get_argument() + 1])
    pc +:= 4
    return
  end

  private store_global()
    global_data[get_argument() + 1] := pop(stack)
    pc +:= 4
    return
  end

  private push_argument()
    push(stack, get_argument())
    pc +:= 4
    return
  end

  private jump()
    pc +:= get_argument()
    return
  end

  private jump_if_zero()
    if pop(stack) = 0 then
      pc +:= get_argument()
    else
      pc +:= 4
    return
  end

  private get_argument()
    return bytes2int(code, pc)
  end

  public initialize()
    # The program counter starts at 1, for convenient indexing into
    # the code[] array. Icon indexing starts at 1 (for a *very* good
    # reason, but that’s a topic for another day).
    pc := 1
    stack := []
    return
  end

  private bad_vm()
    write(FileStream.stderr, "Bad VM.")
    exit(1)
  end

  private bad_opcode()
    write(FileStream.stderr, "Bad opcode.")
    exit(1)
  end
end