%%%-------------------------------------------------------------------

:- module quickselect_task.

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

:- implementation.
:- import_module array.
:- import_module exception.
:- import_module int.
:- import_module list.
:- import_module random.
:- import_module random.sfc64.
:- import_module string.

%%%-------------------------------------------------------------------
%%%
%%% Partitioning a subarray into two halves: one with elements less
%%% than or equal to a pivot, the other with elements greater than or
%%% equal to a pivot.
%%%
%%% The implementation is tail-recursive.
%%%

:- pred partition(pred(T, T), T, int, int, array(T), array(T), int).
:- mode partition(pred(in, in) is semidet, in, in, in,
                  array_di, array_uo, out).
partition(Less_than, Pivot, I_first, I_last, Arr0, Arr, I_pivot) :-
  I = I_first - 1,
  J = I_last + 1,
  partition_loop(Less_than, Pivot, I, J, Arr0, Arr, I_pivot).

:- pred partition_loop(pred(T, T), T, int, int,
                       array(T), array(T), int).
:- mode partition_loop(pred(in, in) is semidet, in, in, in,
                       array_di, array_uo, out).
partition_loop(Less_than, Pivot, I, J, Arr0, Arr, Pivot_index) :-
  if (I = J) then (Arr = Arr0,
                   Pivot_index = I)
  else (I1 = I + 1,
        I2 = search_right(Less_than, Pivot, I1, J, Arr0),
        (if (I2 = J) then (Arr = Arr0,
                           Pivot_index = J)
         else (J1 = J - 1,
               J2 = search_left(Less_than, Pivot, I2, J1, Arr0),
               swap(I2, J2, Arr0, Arr1),
               partition_loop(Less_than, Pivot, I2, J2, Arr1, Arr,
                              Pivot_index)))).

:- func search_right(pred(T, T), T, int, int, array(T)) = int.
:- mode search_right(pred(in, in) is semidet,
                     in, in, in, in) = out is det.
search_right(Less_than, Pivot, I, J, Arr0) = K :-
  if (I = J) then (I = K)
  else if Less_than(Pivot, Arr0^elem(I)) then (I = K)
  else (search_right(Less_than, Pivot, I + 1, J, Arr0) = K).

:- func search_left(pred(T, T), T, int, int, array(T)) = int.
:- mode search_left(pred(in, in) is semidet,
                    in, in, in, in) = out is det.
search_left(Less_than, Pivot, I, J, Arr0) = K :-
  if (I = J) then (J = K)
  else if Less_than(Arr0^elem(J), Pivot) then (J = K)
  else (search_left(Less_than, Pivot, I, J - 1, Arr0) = K).

%%%-------------------------------------------------------------------
%%%
%%% Quickselect with a random pivot.
%%%
%%% The implementation is tail-recursive. One has to pass the routine
%%% a random number generator of type M, attached to the IO state.
%%%
%%% I use a random pivot to get O(n) worst case *expected* running
%%% time. Code using a random pivot is easy to write and read, and for
%%% most purposes comes close enough to a criterion set by Scheme's
%%% SRFI-132: "Runs in O(n) time." (See
%%% https://srfi.schemers.org/srfi-132/srfi-132.html)
%%%
%%% Of course we are not bound here by SRFI-132, but still I respect
%%% it as a guide.
%%%
%%% A "median of medians" pivot gives O(n) running time, but is more
%%% complicated. (That is, of course, assuming you are not writing
%%% your own random number generator and making it a complicated one.)
%%%

%% quickselect/8 selects the (K+1)th largest element of Arr.
:- pred quickselect(pred(T, T)::pred(in, in) is semidet, int::in,
                    array(T)::array_di, array(T)::array_uo,
                    T::out, M::in, io::di, io::uo)
   is det <= urandom(M, io).
quickselect(Less_than, K, Arr0, Arr, Elem, M, !IO) :-
  bounds(Arr0, I_first, I_last),
  quickselect(Less_than, I_first, I_last, K, Arr0, Arr, Elem, M, !IO).

%% quickselect/10 selects the (K+1)th largest element of
%% Arr[I_first..I_last].
:- pred quickselect(pred(T, T)::pred(in, in) is semidet,
                    int::in, int::in, int::in,
                    array(T)::array_di, array(T)::array_uo,
                    T::out, M::in, io::di, io::uo)
   is det <= urandom(M, io).
quickselect(Less_than, I_first, I_last, K, Arr0, Arr, Elem, M, !IO) :-
  if (0 =< K, K =< I_last - I_first)
  then (K_adjusted_for_range = K + I_first,
        quickselect_loop(Less_than, I_first, I_last,
                         K_adjusted_for_range,
                         Arr0, Arr, Elem, M, !IO))
  else throw("out of range").

:- pred quickselect_loop(pred(T, T)::pred(in, in) is semidet,
                         int::in, int::in, int::in,
                         array(T)::array_di, array(T)::array_uo,
                         T::out, M::in, io::di, io::uo)
   is det <= urandom(M, io).
quickselect_loop(Less_than, I_first, I_last, K,
                 Arr0, Arr, Elem, M, !IO) :-
  if (I_first = I_last) then (Arr = Arr0,
                              Elem = Arr0^elem(I_first))
  else (uniform_int_in_range(M, I_first, I_last - I_first + 1,
                             I_pivot, !IO),
        Pivot = Arr0^elem(I_pivot),

        %% Move the last element to where the pivot had been. Perhaps
        %% the pivot was already the last element, of course. In any
        %% case, we shall partition only from I_first to I_last - 1.
        Elem_last = Arr0^elem(I_last),
        Arr1 = (Arr0^elem(I_pivot) := Elem_last),

        %% Partition the array in the range I_first..I_last - 1,
        %% leaving out the last element (which now can be considered
        %% garbage).
        partition(Less_than, Pivot, I_first, I_last - 1, Arr1, Arr2,
                  I_final),

        %% Now everything that is less than the pivot is to the left
        %% of I_final.

        %% Put the pivot at I_final, moving the element that had been
        %% there to the end. If I_final = I_last, then this element is
        %% actually garbage and will be overwritten with the pivot,
        %% which turns out to be the greatest element. Otherwise, the
        %% moved element is not less than the pivot and so the
        %% partitioning is preserved.
        Elem_to_move = Arr2^elem(I_final),
        Arr3 = (Arr2^elem(I_last) := Elem_to_move),
        Arr4 = (Arr3^elem(I_final) := Pivot),

        %% Compare I_final and K, to see what to do next.
        (if (I_final < K)
         then quickselect_loop(Less_than, I_final + 1, I_last, K,
                               Arr4, Arr, Elem, M, !IO)
         else if (K < I_final)
         then quickselect_loop(Less_than, I_first, I_final - 1, K,
                               Arr4, Arr, Elem, M, !IO)
         else (Arr = Arr4,
               Elem = Arr4^elem(I_final)))).

%%%-------------------------------------------------------------------

:- func example_numbers = list(int).
example_numbers = [9, 8, 7, 6, 5, 0, 1, 2, 3, 4].

main(!IO) :-
  (sfc64.init(P, S)),
  make_io_urandom(P, S, M, !IO),
  Print_kth_greatest = (pred(K::in, di, uo) is det -->
                          print_kth_greatest(K, example_numbers, M)),
  Print_kth_least = (pred(K::in, di, uo) is det -->
                       print_kth_least(K, example_numbers, M)),
  print("With < as order predicate: ", !IO),
  foldl(Print_kth_least, 1 `..` 10, !IO),
  print_line("", !IO),
  print("With > as order predicate: ", !IO),
  foldl(Print_kth_greatest, 1 `..` 10, !IO),
  print_line("", !IO).

:- pred print_kth_least(int::in, list(int)::in,
                        M::in, io::di, io::uo)
   is det <= urandom(M, io).
print_kth_least(K, Numbers_list, M, !IO) :-
  (array.from_list(Numbers_list, Arr0)),
  quickselect(<, K - 1, Arr0, _, Elem, M, !IO),
  print(" ", !IO),
  print(Elem, !IO).

:- pred print_kth_greatest(int::in, list(int)::in,
                           M::in, io::di, io::uo)
   is det <= urandom(M, io).
print_kth_greatest(K, Numbers_list, M, !IO) :-
  (array.from_list(Numbers_list, Arr0)),

  %% Notice that the "Less_than" predicate is actually "greater
  %% than". :) One can think of this as meaning that a greater number
  %% has an *ordinal* that is "less than"; that is, it "comes before"
  %% in the order.
  quickselect(>, K - 1, Arr0, _, Elem, M, !IO),

  print(" ", !IO),
  print(Elem, !IO).

%%%-------------------------------------------------------------------
%%% local variables:
%%% mode: mercury
%%% prolog-indent-width: 2
%%% end:


/* NetRexx */
options replace format comments java crossref symbols nobinary
/** @see http://en.wikipedia.org/wiki/Quickselect */

runSample(arg)
return

-- ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
method qpartition(list, ileft, iright, pivotIndex) private static
  pivotValue = list[pivotIndex]
  list = swap(list, pivotIndex, iright) -- Move pivot to end
  storeIndex = ileft
  loop i_ = ileft to iright - 1
    if list[i_] <= pivotValue then do
      list = swap(list, storeIndex, i_)
      storeIndex = storeIndex + 1
      end
    end i_
  list = swap(list, iright, storeIndex) -- Move pivot to its final place
  return storeIndex

-- ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
method qselectInPlace(list, k_, ileft = -1, iright = -1) public static
  if ileft  = -1 then ileft  = 1
  if iright = -1 then iright = list[0]

  loop label inplace forever
    pivotIndex = Random().nextInt(iright - ileft + 1) + ileft -- select pivotIndex between left and right
  pivotNewIndex = qpartition(list, ileft, iright, pivotIndex)
  pivotDist = pivotNewIndex - ileft + 1
  select
    when pivotDist = k_ then do
      returnVal = list[pivotNewIndex]
      leave inplace
      end
    when k_ < pivotDist then
      iright = pivotNewIndex - 1
    otherwise do
      k_ = k_ - pivotDist
      ileft = pivotNewIndex + 1
      end
    end
    end inplace
  return returnVal

-- ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
method swap(list, i1, i2) private static
  if i1 \= i2 then do
    t1       = list[i1]
    list[i1] = list[i2]
    list[i2] = t1
    end
  return list

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method runSample(arg) private static
  parse arg samplelist
  if samplelist = '' | samplelist = '.' then samplelist = 9 8 7 6 5 0 1 2 3 4
  items = samplelist.words
  say 'Input:'
  say '    'samplelist.space(1, ',').changestr(',', ', ')
  say

  say 'Using in-place version of the algorithm:'
  iv = ''
  loop k_ = 1 to items
    iv = iv qselectInPlace(buildIndexedString(samplelist), k_)
    end k_
  say '    'iv.space(1, ',').changestr(',', ', ')
  say

  say 'Find the 4 smallest:'
  iv = ''
  loop k_ = 1 to 4
    iv = iv qselectInPlace(buildIndexedString(samplelist), k_)
    end k_
  say '    'iv.space(1, ',').changestr(',', ', ')
  say

  say 'Find the 3 largest:'
  iv = ''
  loop k_ = items - 2 to items
    iv = iv qselectInPlace(buildIndexedString(samplelist), k_)
    end k_
  say '    'iv.space(1, ',').changestr(',', ', ')
  say

  return

-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
method buildIndexedString(samplelist) private static
  list = 0
  list[0] = samplelist.words()
  loop k_ = 1 to list[0]
    list[k_] = samplelist.word(k_)
    end k_
  return list


proc qselect[T](a: var openarray[T]; k: int, inl = 0, inr = -1): T =
  var r = if inr >= 0: inr else: a.high
  var st = 0
  for i in 0 ..< r:
    if a[i] > a[r]: continue
    swap a[i], a[st]
    inc st

  swap a[r], a[st]

  if k == st:  a[st]
  elif st > k: qselect(a, k, 0, st - 1)
  else:        qselect(a, k, st, inr)

let x = [9, 8, 7, 6, 5, 0, 1, 2, 3, 4]

for i in 0..9:
  var y = x
  echo i, ": ", qselect(y, i)


let rec quickselect k = function
   [] -> failwith "empty"
 | x :: xs -> let ys, zs = List.partition ((>) x) xs in
              let l = List.length ys in
              if k < l then
                quickselect k ys
              else if k > l then
                quickselect (k-l-1) zs
              else
                x


part(list, left, right, pivotIndex)={
  my(pivotValue=list[pivotIndex],storeIndex=left,t);
  t=list[pivotIndex];
  list[pivotIndex]=list[right];
  list[right]=t;
  for(i=left,right-1,
    if(list[i] <= pivotValue,
      t=list[storeIndex];
      list[storeIndex]=list[i];
      list[i]=t;
      storeIndex++
    )
  );
  t=list[right];
  list[right]=list[storeIndex];
  list[storeIndex]=t;
  storeIndex
};
quickselect(list, left, right, n)={
  if(left==right,return(list[left]));
  my(pivotIndex=part(list, left, right, random(right-left)+left));
  if(pivotIndex==n,return(list[n]));
  if(n < pivotIndex,
    quickselect(list, left, pivotIndex - 1, n)
  ,
    quickselect(list, pivotIndex + 1, right, n)
  )
};


my @list = qw(9 8 7 6 5 0 1 2 3 4);
print join ' ', map { qselect(\@list, $_) } 1 .. 10 and print "\n";

sub qselect
{
    my ($list, $k) = @_;
    my $pivot = @$list[int rand @{ $list } - 1];
    my @left  = grep { $_ < $pivot } @$list;
    my @right = grep { $_ > $pivot } @$list;
    if ($k <= @left)
    {
        return qselect(\@left, $k);
    }
    elsif ($k > @left + 1)
    {
        return qselect(\@right, $k - @left - 1);
    }
    else { $pivot }
}


sequence s = {9, 8, 7, 6, 5, 0, 1, 2, 3, 4}

function quick_select(integer k)
    integer left = 1, right = length(s)
    while left<right do
        object pivotv = s[k];
        {s[k], s[right]} = {s[right], s[k]}
        integer pos = left
        for i=left to right do
            if s[i]<pivotv then
                {s[i], s[pos]} = {s[pos], s[i]}
                pos += 1
            end if
        end for
        {s[right], s[pos]} = {s[pos], s[right]}
        if pos==k then exit end if
        if pos<k then
            left = pos + 1
        else
            right = pos - 1
        end if
    end while
    return s[k]
end function

for i=1 to 10 do
    integer r = quick_select(i)
    printf(1," %d",r)
end for
{} = wait_key()


main =>
  L = [9,8,7,6,5,0,1,2,3,4],
  Len = L.len,
  println([select(L,1,Len,I) : I in 1..Len]),
  nl.

select(List, Left, Right, K) = Select =>
  if Left = Right then
    Select = List[Left]
  else
    PivotIndex  = partition(List, Left, Right, random(Left,Right)),
    if K == PivotIndex then
      Select = List[K]
    elseif K < PivotIndex then
      Select = select(List, Left, PivotIndex-1, K)
    else
      Select = select(List, PivotIndex+1, Right, K)
    end
  end.

partition(List, Left, Right, PivotIndex) = StoreIndex =>
  PivotValue = List[PivotIndex],
  swap(List,PivotIndex,Right),
  StoreIndex = Left,
  foreach(I in Left..Right-1)
    if List[I] @< PivotValue then
      swap(List,StoreIndex,I),
      StoreIndex := StoreIndex+1
    end
  end,
  swap(List,Right,StoreIndex).

% swap L[I] <=> L[J]
swap(L,I,J) =>
  T = L[I],
  L[I] := L[J],
  L[J] := T.


(seed (in "/dev/urandom" (rd 8)))
(de swapL (Lst X Y)
   (let L (nth Lst Y)
      (swap
         L
         (swap (nth Lst X) (car L)) ) ) )
(de partition (Lst L R P)
   (let V (get Lst P)
      (swapL Lst R P)
      (for I (range L R)
         (and
            (> V (get Lst I))
            (swapL Lst L I)
            (inc 'L) ) )
      (swapL Lst L R)
      L ) )
(de quick (Lst N L R)
   (default L (inc N)  R (length Lst))
   (if (= L R)
      (get Lst L)
      (let P (partition Lst L R (rand L R))
         (cond
            ((= N P) (get Lst N))
            ((> P N) (quick Lst N L P))
            (T (quick Lst N P R)) ) ) ) )
(let Lst (9 8 7 6 5 0 1 2 3 4)
   (println
      (mapcar
         '((N) (quick Lst N))
         (range 0 9) ) ) )


quick: procedure options (main); /* 4 April 2014 */

partition: procedure (list, left, right, pivot_Index) returns (fixed binary);
   declare list (*) fixed binary;
   declare (left, right, pivot_index) fixed binary;
   declare (store_index, pivot_value) fixed binary;
   declare I fixed binary;

     pivot_Value = list(pivot_Index);
     call swap (pivot_Index, right);  /* Move pivot to end */
     store_Index = left;
     do i = left to right-1;
         if list(i) < pivot_Value then
            do;
               call swap (store_Index, i);
               store_Index = store_index + 1;
            end;
     end;
     call swap (right, store_Index);  /* Move pivot to its final place */
     return (store_Index);

swap: procedure (i, j);
   declare (i, j) fixed binary; declare t fixed binary;

   t = list(i); list(i) = list(j); list(j) = t;
end swap;
end partition;

/* Returns the n-th smallest element of list within left..right inclusive */
/* (i.e. left <= n <= right). */
quick_select: procedure (list, left, right, n) recursive returns (fixed binary);
   declare list(*)          fixed binary;
   declare (left, right, n) fixed binary;
   declare pivot_index      fixed binary;

     if left = right then       /* If the list contains only one element */
         return ( list(left) ); /* Return that element                   */
     pivot_Index  = (left+right)/2;
         /* select a pivot_Index between left and right, */
         /* e.g. left + Math.floor(Math.random() * (right - left + 1)) */
     pivot_Index  = partition(list, left, right, pivot_Index);
     /* The pivot is in its final sorted position. */
     if n = pivot_Index then
         return ( list(n) );
     else if n < pivot_Index then
         return ( quick_select(list, left, pivot_Index - 1, n) );
     else
         return ( quick_select(list, pivot_Index + 1, right, n) );

end quick_select;

   declare a(10) fixed binary static initial (9, 8, 7, 6, 5, 0, 1, 2, 3, 4);
   declare I fixed binary;

   do i = 1 to 10;
      put skip edit ('The ', trim(i), '-th element is ', quick_select((a), 1, 10, (i) )) (a);
   end;

end quick;


 function partition($list, $left, $right, $pivotIndex) {
     $pivotValue = $list[$pivotIndex]
     $list[$pivotIndex], $list[$right] = $list[$right], $list[$pivotIndex]
     $storeIndex = $left
     foreach ($i in $left..($right-1)) {
         if ($list[$i] -lt $pivotValue) {
             $list[$storeIndex],$list[$i] = $list[$i], $list[$storeIndex]
             $storeIndex += 1
         }
     }
     $list[$right],$list[$storeIndex] = $list[$storeIndex], $list[$right]
     $storeIndex
}

function rank($list, $left, $right, $n) {
    if ($left -eq $right) {$list[$left]}
    else {
        $pivotIndex = Get-Random -Minimum $left -Maximum $right
        $pivotIndex = partition $list $left $right $pivotIndex
        if ($n -eq $pivotIndex) {$list[$n]}
        elseif ($n -lt $pivotIndex) {(rank $list $left ($pivotIndex - 1) $n)}
        else {(rank $list ($pivotIndex+1) $right $n)}
    }
}

function quickselect($list) {
    $right = $list.count-1
    foreach($left in 0..$right) {rank $list $left $right $left}
}
$arr = @(9, 8, 7, 6, 5, 0, 1, 2, 3, 4)
"$(quickselect $arr)"


Procedure QuickPartition (Array L(1), left, right, pivotIndex)
     pivotValue = L(pivotIndex)
     Swap L(pivotIndex) , L(right); Move pivot To End
     storeIndex = left
     For i=left To right-1
         If L(i) < pivotValue
             Swap L(storeIndex),L(i)
             storeIndex+1
         EndIf
     Next i
     Swap L(right), L(storeIndex)  ; Move pivot To its final place
     ProcedureReturn storeIndex
 EndProcedure
Procedure QuickSelect(Array L(1), left, right, k)
    Repeat
         If left = right:ProcedureReturn L(left):EndIf
         pivotIndex.i= left; Select pivotIndex between left And right
         pivotIndex= QuickPartition(L(), left, right, pivotIndex)
         If k = pivotIndex
             ProcedureReturn L(k)
         ElseIf k < pivotIndex
             right= pivotIndex - 1
         Else
             left= pivotIndex + 1
         EndIf
    ForEver
EndProcedure
Dim L.i(9)
For i=0 To 9
    Read L(i)
Next i
DataSection
    Data.i 9, 8, 7, 6, 5, 0, 1, 2, 3, 4
EndDataSection
For i=0 To 9
    Debug QuickSelect(L(),0,9,i)
Next i


import random

def partition(vector, left, right, pivotIndex):
    pivotValue = vector[pivotIndex]
    vector[pivotIndex], vector[right] = vector[right], vector[pivotIndex]  # Move pivot to end
    storeIndex = left
    for i in range(left, right):
        if vector[i] < pivotValue:
            vector[storeIndex], vector[i] = vector[i], vector[storeIndex]
            storeIndex += 1
    vector[right], vector[storeIndex] = vector[storeIndex], vector[right]  # Move pivot to its final place
    return storeIndex

def _select(vector, left, right, k):
    "Returns the k-th smallest, (k >= 0), element of vector within vector[left:right+1] inclusive."
    while True:
        pivotIndex = random.randint(left, right)     # select pivotIndex between left and right
        pivotNewIndex = partition(vector, left, right, pivotIndex)
        pivotDist = pivotNewIndex - left
        if pivotDist == k:
            return vector[pivotNewIndex]
        elif k < pivotDist:
            right = pivotNewIndex - 1
        else:
            k -= pivotDist + 1
            left = pivotNewIndex + 1

def select(vector, k, left=None, right=None):
    """\
    Returns the k-th smallest, (k >= 0), element of vector within vector[left:right+1].
    left, right default to (0, len(vector) - 1) if omitted
    """
    if left is None:
        left = 0
    lv1 = len(vector) - 1
    if right is None:
        right = lv1
    assert vector and k >= 0, "Either null vector or k < 0 "
    assert 0 <= left <= lv1, "left is out of range"
    assert left <= right <= lv1, "right is out of range"
    return _select(vector, left, right, k)

if __name__ == '__main__':
    v = [9, 8, 7, 6, 5, 0, 1, 2, 3, 4]
    print([select(v, i) for i in range(10)])


(define (quickselect A k)
  (define pivot (list-ref A (random (length A))))
  (define A1 (filter (curry > pivot) A))
  (define A2 (filter (curry < pivot) A))
  (cond
    [(<= k (length A1)) (quickselect A1 k)]
    [(> k (- (length A) (length A2))) (quickselect A2 (- k (- (length A) (length A2))))]
    [else pivot]))

(define a '(9 8 7 6 5 0 1 2 3 4))
(display (string-join (map number->string (for/list ([k 10]) (quickselect a (+ 1 k)))) ", "))


my @v = <9 8 7 6 5 0 1 2 3 4>;
say map { select(@v, $_) }, 1 .. 10;

sub partition(@vector, $left, $right, $pivot-index) {
    my $pivot-value = @vector[$pivot-index];
    @vector[$pivot-index, $right] = @vector[$right, $pivot-index];
    my $store-index = $left;
    for $left ..^ $right -> $i {
        if @vector[$i] < $pivot-value {
            @vector[$store-index, $i] = @vector[$i, $store-index];
            $store-index++;
        }
    }
    @vector[$right, $store-index] = @vector[$store-index, $right];
    return $store-index;
}

sub select( @vector,
            \k where 1 .. @vector,
            \l where 0 .. @vector = 0,
            \r where l .. @vector = @vector.end ) {

    my ($k, $left, $right) = k, l, r;

    loop {
        my $pivot-index = ($left..$right).pick;
        my $pivot-new-index = partition(@vector, $left, $right, $pivot-index);
        my $pivot-dist = $pivot-new-index - $left + 1;
        given $pivot-dist <=> $k {
            when Same {
                return @vector[$pivot-new-index];
            }
            when More {
                $right = $pivot-new-index - 1;
            }
            when Less {
                $k -= $pivot-dist;
                $left = $pivot-new-index + 1;
            }
        }
    }
}


/*REXX program sorts a list (which may be numbers)  by using the quick select algorithm.*/
parse arg list;  if list=''  then list= 9 8 7 6 5 0 1 2 3 4   /*Not given?  Use default.*/
say right('list: ', 22)           list
#= words(list)
              do i=1  for #;  @.i= word(list, i) /*assign all the items ──► @. (array). */
              end   /*i*/                        /* [↑]  #: number of items in the list.*/
say
      do j=1  for #                              /*show  1 ──►  # items place and value.*/
      say right('item', 20)     right(j, length(#))",  value:  "      qSel(1, #, j)
      end   /*j*/
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
qPart: procedure expose @.;  parse arg L 1 ?,R,X;               xVal= @.X
       parse value  @.X @.R   with   @.R @.X     /*swap the two names items  (X and R). */
             do k=L  to R-1                      /*process the left side of the list.   */
             if @.k>xVal  then iterate           /*when an item > item #X, then skip it.*/
             parse value @.? @.k  with  @.k @.?  /*swap the two named items  (? and K). */
             ?= ? + 1                            /*bump the item number (point to next).*/
             end   /*k*/
       parse       value @.R @.?  with  @.? @.R  /*swap the two named items  (R and ?). */
       return ?                                  /*return the item number to invoker.   */
/*──────────────────────────────────────────────────────────────────────────────────────*/
qSel: procedure expose @.;  parse arg L,R,z;  if L==R  then return @.L  /*only one item?*/
        do forever                               /*keep searching until we're all done. */
        new= qPart(L, R, (L+R) % 2)              /*partition the list into roughly  ½.  */
        $= new - L + 1                           /*calculate pivot distance less  L+1.  */
        if $==z  then return @.new               /*we're all done with this pivot part. */
                 else if  z<$  then     R= new-1 /*decrease the right half of the array.*/
                               else do; z= z-$   /*decrease the distance.               */
                                        L= new+1 /*increase the  left half *f the array.*/
                                    end
        end   /*forever*/


aList = [9, 8, 7, 6, 5, 0, 1, 2, 3, 4]
see partition(aList, 9, 4, 2) + nl

func partition list, left, right, pivotIndex
       pivotValue = list[pivotIndex]
       temp = list[pivotIndex]
       list[pivotIndex] = list[right]
       list[right]  = temp
       storeIndex = left
       for i = left to right-1
            if list[i] < pivotValue
               temp = list[storeIndex]
               list[storeIndex] = list[i]
               list[i] = temp
               storeIndex++ ok
            temp = list[right]
            list[right] = list[storeIndex]
            list[storeIndex] = temp
       next
       return storeIndex


def quickselect(a, k)
  arr = a.dup # we will be modifying it
  loop do
    pivot = arr.delete_at(rand(arr.length))
    left, right = arr.partition { |x| x < pivot }
    if k == left.length
      return pivot
    elsif k < left.length
      arr = left
    else
      k = k - left.length - 1
      arr = right
    end
  end
end

v = [9, 8, 7, 6, 5, 0, 1, 2, 3, 4]
p v.each_index.map { |i| quickselect(v, i) }


// See https://en.wikipedia.org/wiki/Quickselect

fn partition<T: PartialOrd>(a: &mut [T], left: usize, right: usize, pivot: usize) -> usize {
    a.swap(pivot, right);
    let mut store_index = left;
    for i in left..right {
        if a[i] < a[right] {
            a.swap(store_index, i);
            store_index += 1;
        }
    }
    a.swap(right, store_index);
    store_index
}

fn pivot_index(left: usize, right: usize) -> usize {
    return left + (right - left) / 2;
}

fn select<T: PartialOrd>(a: &mut [T], mut left: usize, mut right: usize, n: usize) {
    loop {
        if left == right {
            break;
        }
        let mut pivot = pivot_index(left, right);
        pivot = partition(a, left, right, pivot);
        if n == pivot {
            break;
        } else if n < pivot {
            right = pivot - 1;
        } else {
            left = pivot + 1;
        }
    }
}

// Rearranges the elements of 'a' such that the element at index 'n' is
// the same as it would be if the array were sorted, smaller elements are
// to the left of it and larger elements are to its right.
fn nth_element<T: PartialOrd>(a: &mut [T], n: usize) {
    select(a, 0, a.len() - 1, n);
}

fn main() {
    let a = vec![9, 8, 7, 6, 5, 0, 1, 2, 3, 4];
    for n in 0..a.len() {
        let mut b = a.clone();
        nth_element(&mut b, n);
        println!("n = {}, nth element = {}", n + 1, b[n]);
    }
}


import scala.util.Random

object QuickSelect {
  def quickSelect[A <% Ordered[A]](seq: Seq[A], n: Int, rand: Random = new Random): A = {
    val pivot = rand.nextInt(seq.length);
    val (left, right) = seq.partition(_ < seq(pivot))
    if (left.length == n) {
      seq(pivot)
    } else if (left.length < n) {
      quickSelect(right, n - left.length, rand)
    } else {
      quickSelect(left, n, rand)
    }
  }

  def main(args: Array[String]): Unit = {
    val v = Array(9, 8, 7, 6, 5, 0, 1, 2, 3, 4)
    println((0 until v.length).map(quickSelect(v, _)).mkString(", "))
  }
}


;;
;; Quickselect with random pivot.
;;
;; Such a pivot provides O(n) worst-case *expected* time.
;;
;; One can get true O(n) time by using "median of medians" to choose
;; the pivot, but quickselect with a median of medians pivot is a
;; complicated algorithm. See
;; https://en.wikipedia.org/w/index.php?title=Median_of_medians&oldid=1082505985
;;
;; Random pivot has the further advantage that it does not require any
;; comparisons of array elements.
;;
;; By the way, SRFI-132 specifies that vector-select! have O(n)
;; running time, and yet the reference implementation (as of 21 May
;; 2022) uses random pivot. I am pretty sure you cannot count on an
;; implementation having "true" O(n) behavior.
;;

(import (scheme base))
(import (scheme case-lambda))
(import (scheme write))
(import (only (scheme process-context) exit))
(import (only (srfi 27) random-integer))

(define (vector-swap! vec i j)
  (let ((xi (vector-ref vec i))
        (xj (vector-ref vec j)))
    (vector-set! vec i xj)
    (vector-set! vec j xi)))

(define (search-right <? pivot i j vec)
  (let loop ((i i))
    (cond ((= i j) i)
          ((<? pivot (vector-ref vec i)) i)
          (else (loop (+ i 1))))))

(define (search-left <? pivot i j vec)
  (let loop ((j j))
    (cond ((= i j) j)
          ((<? (vector-ref vec j) pivot) j)
          (else (loop (- j 1))))))

(define (partition <? pivot i-first i-last vec)
  ;; Partition a subvector into two halves: one with elements less
  ;; than or equal to a pivot, the other with elements greater than or
  ;; equal to a pivot. Returns an index where anything less than the
  ;; pivot is to the left of the index, and anything greater than the
  ;; pivot is either at the index or to its right. The implementation
  ;; is tail-recursive.
  (let loop ((i (- i-first 1))
             (j (+ i-last 1)))
    (if (= i j)
        i
        (let ((i (search-right <? pivot (+ i 1) j vec)))
          (if (= i j)
              i
              (let ((j (search-left <? pivot i (- j 1) vec)))
                (vector-swap! vec i j)
                (loop i j)))))))

(define (partition-around-random-pivot <? i-first i-last vec)
  (let* ((i-pivot (+ i-first (random-integer (- i-last i-first -1))))
         (pivot (vector-ref vec i-pivot)))

    ;; Move the last element to where the pivot had been. Perhaps the
    ;; pivot was already the last element, of course. In any case, we
    ;; shall partition only from I_first to I_last - 1.
    (vector-set! vec i-pivot (vector-ref vec i-last))

    ;; Partition the array in the range I_first..I_last - 1, leaving
    ;; out the last element (which now can be considered garbage).
    (let ((i-final (partition <? pivot i-first (- i-last 1) vec)))

      ;; Now everything that is less than the pivot is to the left of
      ;; I_final.

      ;; Put the pivot at I_final, moving the element that had been
      ;; there to the end. If I_final = I_last, then this element is
      ;; actually garbage and will be overwritten with the pivot,
      ;; which turns out to be the greatest element. Otherwise, the
      ;; moved element is not less than the pivot and so the
      ;; partitioning is preserved.
      (vector-set! vec i-last (vector-ref vec i-final))
      (vector-set! vec i-final pivot)

      ;; Return i-final, the final position of the pivot element.
      i-final)))

(define quickselect!
  (case-lambda

    ((<? vec k)
     ;; Select the (k+1)st least element of vec.
     (quickselect! <? 0 (- (vector-length vec) 1) vec k))

    ((<? i-first i-last vec k)
     ;; Select the (k+1)st least element of vec[i-first..i-last].
     (unless (and (<= 0 k) (<= k (- i-last i-first)))
       ;; Here you more likely want to raise an exception, but how to
       ;; do so is not specified in R7RS small. (It *is* specified in
       ;; R6RS, but R6RS features are widely unsupported by Schemes.)
       (display "out of range" (current-error-port))
       (exit 1))
     (let ((k (+ k i-first)))           ; Adjust k for index range.
       (let loop ((i-first i-first)
                  (i-last i-last))
         (if (= i-first i-last)
             (vector-ref vec i-first)
             (let ((i-final (partition-around-random-pivot
                             <? i-first i-last vec)))
               ;; Compare i-final and k, to see what to do next.
               (cond ((< i-final k) (loop (+ i-final 1) i-last))
                     ((< k i-final) (loop i-first (- i-final 1)))
                     (else (vector-ref vec i-final))))))))))

(define (print-kth <? k numbers-vector)
  (let* ((vec (vector-copy numbers-vector))
         (elem (quickselect! <? vec (- k 1))))
    (display " ")
    (display elem)))

(define example-numbers #(9 8 7 6 5 0 1 2 3 4))

(display "With < as order predicate: ")
(do ((k 1 (+ k 1)))
    ((= k 11))
  (print-kth < k example-numbers))
(newline)
(display "With > as order predicate: ")
(do ((k 1 (+ k 1)))
    ((= k 11))
  (print-kth > k example-numbers))
(newline)


func quickselect(a, k) {
    var pivot = a.pick;
    var left  = a.grep{|i| i < pivot};
    var right = a.grep{|i| i > pivot};

    given(var l = left.len) {
        when (k)     { pivot }
        case (k < l) { __FUNC__(left, k) }
        default      { __FUNC__(right, k - l - 1) }
    }
}

var v = [9, 8, 7, 6, 5, 0, 1, 2, 3, 4];
say v.range.map{|i| quickselect(v, i)};


fun quickselect (_, _, []) = raise Fail "empty"
  | quickselect (k, cmp, x :: xs) = let
        val (ys, zs) = List.partition (fn y => cmp (y, x) = LESS) xs
        val l = length ys
      in
        if k < l then
          quickselect (k, cmp, ys)
        else if k > l then
          quickselect (k-l-1, cmp, zs)
        else
          x
      end


func select<T where T : Comparable>(var elements: [T], n: Int) -> T {
  var r = indices(elements)
  while true {
    let pivotIndex = partition(&elements, r)
    if n == pivotIndex {
      return elements[pivotIndex]
    } else if n < pivotIndex {
      r.endIndex = pivotIndex
    } else {
      r.startIndex = pivotIndex+1
    }
  }
}

for i in 0 ..< 10 {
  let a = [9, 8, 7, 6, 5, 0, 1, 2, 3, 4]
  print(select(a, i))
  if i < 9 { print(", ") }
}
println()


# Swap the values at two indices of a list
proc swap {list i j} {
    upvar 1 $list l
    set tmp [lindex $l $i]
    lset l $i [lindex $l $j]
    lset l $j $tmp
}

proc quickselect {vector k {left 0} {right ""}} {
    set last [expr {[llength $vector] - 1}]
    if {$right eq ""} {
	set right $last
    }
    # Sanity assertions
    if {![llength $vector] || $k <= 0} {
	error "Either empty vector, or k <= 0"
    } elseif {![tcl::mathop::<= 0 $left $last]} {
	error "left is out of range"
    } elseif {![tcl::mathop::<= $left $right $last]} {
	error "right is out of range"
    }

    # the _select core, inlined
    while 1 {
	set pivotIndex [expr {int(rand()*($right-$left))+$left}]

	# the partition core, inlined
	set pivotValue [lindex $vector $pivotIndex]
	swap vector $pivotIndex $right
	set storeIndex $left
	for {set i $left} {$i <= $right} {incr i} {
	    if {[lindex $vector $i] < $pivotValue} {
		swap vector $storeIndex $i
		incr storeIndex
	    }
	}
	swap vector $right $storeIndex
	set pivotNewIndex $storeIndex

	set pivotDist [expr {$pivotNewIndex - $left + 1}]
	if {$pivotDist == $k} {
	    return [lindex $vector $pivotNewIndex]
	} elseif {$k < $pivotDist} {
	    set right [expr {$pivotNewIndex - 1}]
	} else {
	    set k [expr {$k - $pivotDist}]
	    set left [expr {$pivotNewIndex + 1}]
	}
    }
}


Dim s As Variant
Private Function quick_select(ByRef s As Variant, k As Integer) As Integer
    Dim left As Integer, right As Integer, pos As Integer
    Dim pivotValue As Integer, tmp As Integer
    left = 1: right = UBound(s)
    Do While left < right
        pivotValue = s(k)
        tmp = s(k)
        s(k) = s(right)
        s(right) = tmp
        pos = left
        For i = left To right
            If s(i) < pivotValue Then
                tmp = s(i)
                s(i) = s(pos)
                s(pos) = tmp
                pos = pos + 1
            End If
        Next i
        tmp = s(right)
        s(right) = s(pos)
        s(pos) = tmp
        If pos = k Then
            Exit Do
        End If
        If pos < k Then
            left = pos + 1
        Else
            right = pos - 1
        End If
    Loop
    quick_select = s(k)
End Function
Public Sub main()
    Dim r As Integer, i As Integer
    s = [{9, 8, 7, 6, 5, 0, 1, 2, 3, 4}]
    For i = 1 To 10
        r = quick_select(s, i) 's is ByRef parameter
        Debug.Print IIf(i < 10, r & ", ", "" & r);
    Next i
End Sub


import "/sort" for Find

var a = [9, 8, 7, 6, 5, 0, 1, 2, 3, 4]
for (k in 0..9) {
    System.write(Find.quick(a, k))
    if (k < 9) System.write(", ")
}
System.print()


fcn qselect(list,nth){	// in place quick select
   fcn(list,left,right,nth){
      if (left==right) return(list[left]);
      pivotIndex:=(left+right)/2; // or median of first,middle,last

      	// partition
      pivot:=list[pivotIndex];
      list.swap(pivotIndex,right);	// move pivot to end
      pivotIndex := left;
      i:=left; do(right-left){	// foreach i in ([left..right-1])
	 if (list[i] < pivot){
	    list.swap(i,pivotIndex);
	    pivotIndex += 1;
	 }
	 i += 1;
      }
      list.swap(pivotIndex,right);	// move pivot to final place

      if (nth==pivotIndex) return(list[nth]);
      if (nth<pivotIndex)  return(self.fcn(list,left,pivotIndex-1,nth));
      return(self.fcn(list,pivotIndex+1,right,nth));
   }(list.copy(),0,list.len()-1,nth);
}


REPORT R NO STANDARD PAGE HEADING LINE-SIZE 67.
DATA:A(440),B,C,N(3) TYPE N,I TYPE I,S.
A+000 = 'REPORT R NO STANDARD PAGE HEADING LINE-SIZE 6\7.1DATA:A'.
A+055 = '(440),B,C,N(\3) TYPE N,I TYPE I,S.?1DO 440 TIMES.3C = A'.
A+110 = '+I.3IF B = S.5IF C CA `\\\?\1\3\5\7`.7B = C.5ELSEIF C ='.
A+165 = ' `\``.7WRITE ```` NO-GAP.5ELSE.7WRITE C NO-GAP.5ENDIF.3'.
A+220 = 'ELSEIF B = `\\`.5WRITE C NO-GAP.5B = S.3ELSEIF B = `\?`'.
A+275 = '.5DO 8 TIMES.7WRITE:/ `A+` NO-GAP,N,`= ``` NO-GAP,A+N(\'.
A+330 = '5\5) NO-GAP,```.`.7N = N + \5\5.5ENDDO.5B = C.3ELSE.5WR'.
A+385 = 'ITE AT /B C NO-GAP.5B = S.3ENDIF.3I = I + \1.1ENDDO.   '.
DO 440 TIMES.
  C = A+I.
  IF B = S.
    IF C CA '\?1357'.
      B = C.
    ELSEIF C = '`'.
      WRITE '''' NO-GAP.
    ELSE.
      WRITE C NO-GAP.
    ENDIF.
  ELSEIF B = '\'.
    WRITE C NO-GAP.
    B = S.
  ELSEIF B = '?'.
    DO 8 TIMES.
      WRITE:/ 'A+' NO-GAP,N,'= ''' NO-GAP,A+N(55) NO-GAP,'''.'.
      N = N + 55.
    ENDDO.
    B = C.
  ELSE.
    WRITE AT /B C NO-GAP.
    B = S.
  ENDIF.
  I = I + 1.
ENDDO.


(defun print-quine (quine)
   (cw quine quine))
(print-quine
"(defun print-quine (quine)
  (cw quine quine))
(print-quine ~x0)~%")


1⌽,⍨9⍴'''1⌽,⍨9⍴'''        ⍝ Author: Nikolay Nikolov; Source: https://dfns.dyalog.com/n_quine.htm


block: [print ["block:" as .code block "do block"]] do block


FileRead, quine, %A_ScriptFullPath%
MsgBox % quine


#!/bin/bash
mapfile < $0
printf "%s" "${MAPFILE[@]}"


PRINT $(PAGE+22)$(PAGE+21):REM PRINT $(PAGE+22)$(PAGE+21):REM


c=","; n="\n"; q="\""; s="\\";
v=\[
"c=\",\"; n=\"\\n\"; q=\"\\\"\"; s=\"\\\\\";",
"v=\\[",
"define prtQuote(str) {",
" local j,t,v;",
" stdout.Display(q);",
" for (j=0; j<str.size; j++) {",
"  t = str.Substring(j,1);",
"  if (t==q) { stdout.Display(s); }",
"  if (t==s) { stdout.Display(s); }",
"  stdout.Display(t);",
" }",
" stdout.Display(q);",
"}",
"for(i=0; i<2; i++){ stdout.Display(v[i]); stdout.Display(n); }",
"for(i=0; i<v.size-1; i++){ prtQuote(v[i]); stdout.Display(c); stdout.Display(n); }",
"prtQuote(v[v.size-1]); stdout.Display(n);",
"stdout.Display(v[v.size-1]); stdout.Display(n);",
"for(i=2; i<v.size-1; i++){ stdout.Display(v[i]); stdout.Display(n); }",
"];"
];
define prtQuote(str) {
 local j,t,v;
 stdout.Display(q);
 for (j=0; j<str.size; j++) {
  t = str.Substring(j,1);
  if (t==q) { stdout.Display(s); }
  if (t==s) { stdout.Display(s); }
  stdout.Display(t);
 }
 stdout.Display(q);
}
for(i=0; i<2; i++){ stdout.Display(v[i]); stdout.Display(n); }
for(i=0; i<v.size-1; i++){ prtQuote(v[i]); stdout.Display(c); stdout.Display(n); }
prtQuote(v[v.size-1]); stdout.Display(n);
stdout.Display(v[v.size-1]); stdout.Display(n);
for(i=2; i<v.size-1; i++){ stdout.Display(v[i]); stdout.Display(n); }


#include <stdio.h>

static char sym[] = "\n\t\\\"";

int main(void) {
	const char *code = "#include <stdio.h>%c%cstatic char sym[] = %c%cn%ct%c%c%c%c%c;%c%cint main(void) {%c%cconst char *code = %c%s%c;%c%cprintf(code, sym[0], sym[0], sym[3], sym[2], sym[2], sym[2], sym[2], sym[2], sym[3], sym[3], sym[0], sym[0], sym[0], sym[1], sym[3], code, sym[3], sym[0], sym[1], sym[0], sym[0], sym[1], sym[0], sym[0]);%c%c%creturn 0;%c}%c";
	printf(code, sym[0], sym[0], sym[3], sym[2], sym[2], sym[2], sym[2], sym[2], sym[3], sym[3], sym[0], sym[0], sym[0], sym[1], sym[3], code, sym[3], sym[0], sym[1], sym[0], sym[0], sym[1], sym[0], sym[0]);

	return 0;
}


class Program { static void Main() { var s = "class Program {{ static void Main() {{ var s = {0}{1}{0}; System.Console.WriteLine(s, (char)34, s); }} }}"; System.Console.WriteLine(s, (char)34, s); } }


#include<cstdio>
int main(){char n[]=R"(#include<cstdio>
int main(){char n[]=R"(%s%c";printf(n,n,41);})";printf(n,n,41);}


((fn [x] (list x (list (quote quote) x))) (quote (fn [x] (list x (list (quote quote) x)))))


q="start_up=proc()\n"||
"    po:stream:=stream$primary_output()\n"||
"    stream$puts(po,\"q=\\\"\")\n"||
"    for c:char in string$chars(q) do\n"||
"        if c='\\n' then stream$puts(po,\"\\\\n\\\"||\\n\\\"\")\n"||
"        elseif c='\\\\' then stream$puts(po,\"\\\\\\\\\")\n"||
"        elseif c='\\\"' then stream$puts(po,\"\\\\\\\"\")\n"||
"        else stream$putc(po,c)\n"||
"        end\n"||
"    end\n"||
"    stream$puts(po,\"\\\"\\n\"||q)\n"||
"end start_up\n"||
""
start_up=proc()
    po:stream:=stream$primary_output()
    stream$puts(po,"q=\"")
    for c:char in string$chars(q) do
        if c='\n' then stream$puts(po,"\\n\"||\n\"")
        elseif c='\\' then stream$puts(po,"\\\\")
        elseif c='\"' then stream$puts(po,"\\\"")
        else stream$putc(po,c)
        end
    end
    stream$puts(po,"\"\n"||q)
end start_up


((lambda (s) (print (list s (list 'quote s))))
 '(lambda (s) (print (list s (list 'quote s)))))


const auto s=`const auto q="const auto s=\x60"~s~"\x60;
mixin(s);";import std.stdio;void main(){writefln(q);pragma(msg,q);}`;
mixin(s);


syntax{Q $EXP}as{io.writef('syntax{Q $EXP}as{%s}Q %s',\'$EXP\',\'$EXP\')}Q io.writef('syntax{Q $EXP}as{%s}Q %s',\'$EXP\',\'$EXP\')


*char q=
"proc main() void:\r\n"
"    [128]char l;\r\n"
"    char ch;\r\n"
"    channel input text qc, lc;\r\n"
"    open(qc, q);\r\n"
"    writeln(\"*char q=\");\r\n"
"    while readln(qc; &l[0]) do\r\n"
"        write('\"');\r\n"
"        open(lc, &l[0]);\r\n"
"        while read(lc; ch) do\r\n"
"            if ch='\"' or ch='\\\\' then write('\\\\') fi;\r\n"
"            write(ch)\r\n"
"        od;\r\n"
"        close(lc);\r\n"
"        writeln(\"\\\\r\\\\n\\\"\")\r\n"
"    od;\r\n"
"    close(qc);\r\n"
"    writeln(';');\r\n"
"    writeln(q)\r\n"
"corp\r\n"
;
proc main() void:
    [128]char l;
    char ch;
    channel input text qc, lc;
    open(qc, q);
    writeln("*char q=");
    while readln(qc; &l[0]) do
        write('"');
        open(lc, &l[0]);
        while read(lc; ch) do
            if ch='"' or ch='\\' then write('\\') fi;
            write(ch)
        od;
        close(lc);
        writeln("\\r\\n\"")
    od;
    close(qc);
    writeln(';');
    writeln(q)
corp


" =~ x; println(E.toQuote(x),x)" =~ x; println(E.toQuote(x),x)


a = <<"a = ~p~n:io.fwrite(a,[a])~n">>
:io.fwrite(a,[a])


PROGRAM QUINE
BEGIN
READ(D$,Y$)
LOOP
    READ(X$)
    EXIT IF LEN(X$)<1
    PRINT(X$)
END LOOP
RESTORE
LOOP
    READ(X$)
    EXIT IF LEN(X$)<1
    PRINT(D$;CHR$(34);X$;CHR$(34);CHR$(41))
END LOOP
PRINT(D$;CHR$(34);CHR$(34);CHR$(41))
PRINT(Y$)
DATA("DATA(")
DATA("END PROGRAM")
DATA("PROGRAM QUINE")
DATA("BEGIN")
DATA("READ(D$,Y$)")
DATA("LOOP")
DATA("    READ(X$)")
DATA("    EXIT IF LEN(X$)<1")
DATA("    PRINT(X$)")
DATA("END LOOP")
DATA("RESTORE")
DATA("LOOP")
DATA("    READ(X$)")
DATA("    EXIT IF LEN(X$)<1")
DATA("    PRINT(D$;CHR$(34);X$;CHR$(34);CHR$(41))")
DATA("END LOOP")
DATA("PRINT(D$;CHR$(34);CHR$(34);CHR$(41))")
DATA("PRINT(Y$)")
DATA("")
END PROGRAM


constant p="constant p=%s%s%s printf(1,p,{34,p,34})" printf(1,p,{34,p,34})


let s = "let s = {0}{1}{0} in System.Console.WriteLine(s, char 34, s);;" in System.Console.WriteLine(s, char 34, s);;


"%s [ 34 1string dup surround ] keep printf" [ 34 1string dup surround ] keep printf


#Define P(X) Print X: Print "P(" & #X & ")"
P("#Define P(X) Print X: Print ""P("" & #X & "")""")


"#s sto selfstring QUOTE @selfstring dup print QUOTE NL printnl end { „selfstring” }"
#s sto selfstring QUOTE @selfstring dup print QUOTE NL printnl end { „selfstring” }


dim s as string="dim s as string=&1&2&3&4print subst(s,chr(34),s,chr(34),chr(10))"
print subst(s,chr(34),s,chr(34),chr(10))


f:=function (  )
    Print( "f:=", f, ";;\nf();\n" );
    return;
end;;
f();


package main

import "fmt"

func main() {
	a := "package main\n\nimport \"fmt\"\n\nfunc main() {\n\ta := %q\n\tfmt.Printf(a, a)\n}\n"
	fmt.Printf(a, a)
}


use fmt;
const src: str = "use fmt;
const src: str = {0}{1}{0};
export fn main() void = {{fmt::printfln(src, '{0}', src)!;}};";
export fn main() void = {fmt::printfln(src, '"', src)!;};


let q s = putStrLn (s ++ show s) in q "let q s = putStrLn (s ++ show s) in q "


!:  :-  %say  |=  [^ [~ ~]]  =+  ^=  s  ((list ,@tas) ~['!:  :-  %say  |=  [^ [~ ~]]  =+  ^=  s  ((list ,@tas) ~[' 'x' '])  :-  %noun  (,tape (turn s |=([email protected] ?:(=(a %x) (crip `(list ,@tas)`(turn s |=([email protected] =+([s=?:(=(b %x) " " "") m=(trip ~~~27.)] (crip :(welp s m (trip b) m s)))))) a))))'])  :-  %noun  (,tape (turn s |=([email protected] ?:(=(a %x) (crip `(list ,@tas)`(turn s |=([email protected] =+([s=?:(=(b %x) " " "") m=(trip ~~~27.)] (crip :(welp s m (trip b) m s)))))) a))))


<!DOCTYPE html>
<html>
<head>
	<title>HTML/CSS Quine</title>
	<style type="text/css">
	* { font: 10pt monospace; }

	head, style { display: block; }
	style { white-space: pre; }

	style:before {
		content:
			"\3C""!DOCTYPE html\3E"
			"\A\3Chtml\3E\A"
			"\3Chead\3E\A"
			"\9\3Ctitle\3E""HTML/CSS Quine""\3C/title\3E\A"
			"\9\3Cstyle type=\22text/css\22\3E";
	}
	style:after {
		content:
			"\3C/style\3E\A"
			"\3C/head\3E\A"
			"\3C""body\3E\3C/body\3E\A"
			"\3C/html\3E";
	}
	</style>
</head>
<body></body>
</html>


procedure main();x:="write(\"procedure main();x:=\",image(x));write(x);end"
write("procedure main();x:=",image(x));write(x);end


R is a room. To quit: (- quit; -). When play begins: say entry 1 in Q; say Q in brace notation; quit. Q is a list of text variable. Q is {"R is a room. To quit: (- quit; -). When play begins: say entry 1 in Q; say Q in brace notation; quit. Q is a list of text variable. Q is "}


"dup put putchars 10 putch." dup put putchars 10 putch.


var code='var q=String.fromCharCode(39);puts("var code="+q+code+q+";eval(code)")';eval(code)


// version 1.1.2

const val F = """// version 1.1.2

const val F = %c%c%c%s%c%c%c

fun main(args: Array<String>) {
    System.out.printf(F, 34, 34, 34, F, 34, 34, 34)
}
"""

fun main(args: Array<String>) {
    System.out.printf(F, 34, 34, 34, F, 34, 34, 34)
}


{{lambda {:x} :x} '{lambda {:x} :x}}
-> {lambda {:x} :x}


DATA:
  A IS NUMBER VECTOR
  C IS TEXT
  N IS NUMBER
  I IS NUMBER
  J IS NUMBER
PROCEDURE:

  SUB-PROCEDURE SHOWU
    STORE 0 IN I
    WHILE I IS LESS THAN N DO
        DISPLAY "  STORE "
        DISPLAY A:I
        DISPLAY " IN "
        DISPLAY " A:"
        DISPLAY I CRLF
        ADD I AND 1 IN I
    REPEAT
    DISPLAY "  STORE "
    DISPLAY N
    DISPLAY " IN N" CRLF
  END SUB-PROCEDURE

  SUB-PROCEDURE SHOW
    STORE 0 IN J
    WHILE J IS LESS THAN N DO
        IF A:J IS EQUAL TO 42 THEN
          CALL SUB-PROCEDURE SHOWU
        ELSE
          STORE CHARACTER A:J IN C
          DISPLAY C
        END-IF
        ADD J AND 1 IN J
    REPEAT
  END SUB-PROCEDURE

  STORE 10 IN  A:0
  STORE 68 IN  A:1
  STORE 65 IN  A:2
  STORE 84 IN  A:3
  STORE 65 IN  A:4
  STORE 58 IN  A:5
  STORE 10 IN  A:6
  STORE 32 IN  A:7
  STORE 32 IN  A:8
  STORE 65 IN  A:9
  STORE 32 IN  A:10
  STORE 73 IN  A:11
  STORE 83 IN  A:12
  STORE 32 IN  A:13
  STORE 78 IN  A:14
  STORE 85 IN  A:15
  STORE 77 IN  A:16
  STORE 66 IN  A:17
  STORE 69 IN  A:18
  STORE 82 IN  A:19
  STORE 32 IN  A:20
  STORE 86 IN  A:21
  STORE 69 IN  A:22
  STORE 67 IN  A:23
  STORE 84 IN  A:24
  STORE 79 IN  A:25
  STORE 82 IN  A:26
  STORE 10 IN  A:27
  STORE 32 IN  A:28
  STORE 32 IN  A:29
  STORE 67 IN  A:30
  STORE 32 IN  A:31
  STORE 73 IN  A:32
  STORE 83 IN  A:33
  STORE 32 IN  A:34
  STORE 84 IN  A:35
  STORE 69 IN  A:36
  STORE 88 IN  A:37
  STORE 84 IN  A:38
  STORE 10 IN  A:39
  STORE 32 IN  A:40
  STORE 32 IN  A:41
  STORE 78 IN  A:42
  STORE 32 IN  A:43
  STORE 73 IN  A:44
  STORE 83 IN  A:45
  STORE 32 IN  A:46
  STORE 78 IN  A:47
  STORE 85 IN  A:48
  STORE 77 IN  A:49
  STORE 66 IN  A:50
  STORE 69 IN  A:51
  STORE 82 IN  A:52
  STORE 10 IN  A:53
  STORE 32 IN  A:54
  STORE 32 IN  A:55
  STORE 73 IN  A:56
  STORE 32 IN  A:57
  STORE 73 IN  A:58
  STORE 83 IN  A:59
  STORE 32 IN  A:60
  STORE 78 IN  A:61
  STORE 85 IN  A:62
  STORE 77 IN  A:63
  STORE 66 IN  A:64
  STORE 69 IN  A:65
  STORE 82 IN  A:66
  STORE 10 IN  A:67
  STORE 32 IN  A:68
  STORE 32 IN  A:69
  STORE 74 IN  A:70
  STORE 32 IN  A:71
  STORE 73 IN  A:72
  STORE 83 IN  A:73
  STORE 32 IN  A:74
  STORE 78 IN  A:75
  STORE 85 IN  A:76
  STORE 77 IN  A:77
  STORE 66 IN  A:78
  STORE 69 IN  A:79
  STORE 82 IN  A:80
  STORE 10 IN  A:81
  STORE 80 IN  A:82
  STORE 82 IN  A:83
  STORE 79 IN  A:84
  STORE 67 IN  A:85
  STORE 69 IN  A:86
  STORE 68 IN  A:87
  STORE 85 IN  A:88
  STORE 82 IN  A:89
  STORE 69 IN  A:90
  STORE 58 IN  A:91
  STORE 10 IN  A:92
  STORE 10 IN  A:93
  STORE 32 IN  A:94
  STORE 32 IN  A:95
  STORE 83 IN  A:96
  STORE 85 IN  A:97
  STORE 66 IN  A:98
  STORE 45 IN  A:99
  STORE 80 IN  A:100
  STORE 82 IN  A:101
  STORE 79 IN  A:102
  STORE 67 IN  A:103
  STORE 69 IN  A:104
  STORE 68 IN  A:105
  STORE 85 IN  A:106
  STORE 82 IN  A:107
  STORE 69 IN  A:108
  STORE 32 IN  A:109
  STORE 83 IN  A:110
  STORE 72 IN  A:111
  STORE 79 IN  A:112
  STORE 87 IN  A:113
  STORE 85 IN  A:114
  STORE 10 IN  A:115
  STORE 32 IN  A:116
  STORE 32 IN  A:117
  STORE 32 IN  A:118
  STORE 32 IN  A:119
  STORE 83 IN  A:120
  STORE 84 IN  A:121
  STORE 79 IN  A:122
  STORE 82 IN  A:123
  STORE 69 IN  A:124
  STORE 32 IN  A:125
  STORE 48 IN  A:126
  STORE 32 IN  A:127
  STORE 73 IN  A:128
  STORE 78 IN  A:129
  STORE 32 IN  A:130
  STORE 73 IN  A:131
  STORE 10 IN  A:132
  STORE 32 IN  A:133
  STORE 32 IN  A:134
  STORE 32 IN  A:135
  STORE 32 IN  A:136
  STORE 87 IN  A:137
  STORE 72 IN  A:138
  STORE 73 IN  A:139
  STORE 76 IN  A:140
  STORE 69 IN  A:141
  STORE 32 IN  A:142
  STORE 73 IN  A:143
  STORE 32 IN  A:144
  STORE 73 IN  A:145
  STORE 83 IN  A:146
  STORE 32 IN  A:147
  STORE 76 IN  A:148
  STORE 69 IN  A:149
  STORE 83 IN  A:150
  STORE 83 IN  A:151
  STORE 32 IN  A:152
  STORE 84 IN  A:153
  STORE 72 IN  A:154
  STORE 65 IN  A:155
  STORE 78 IN  A:156
  STORE 32 IN  A:157
  STORE 78 IN  A:158
  STORE 32 IN  A:159
  STORE 68 IN  A:160
  STORE 79 IN  A:161
  STORE 10 IN  A:162
  STORE 32 IN  A:163
  STORE 32 IN  A:164
  STORE 32 IN  A:165
  STORE 32 IN  A:166
  STORE 32 IN  A:167
  STORE 32 IN  A:168
  STORE 32 IN  A:169
  STORE 32 IN  A:170
  STORE 68 IN  A:171
  STORE 73 IN  A:172
  STORE 83 IN  A:173
  STORE 80 IN  A:174
  STORE 76 IN  A:175
  STORE 65 IN  A:176
  STORE 89 IN  A:177
  STORE 32 IN  A:178
  STORE 34 IN  A:179
  STORE 32 IN  A:180
  STORE 32 IN  A:181
  STORE 83 IN  A:182
  STORE 84 IN  A:183
  STORE 79 IN  A:184
  STORE 82 IN  A:185
  STORE 69 IN  A:186
  STORE 32 IN  A:187
  STORE 34 IN  A:188
  STORE 10 IN  A:189
  STORE 32 IN  A:190
  STORE 32 IN  A:191
  STORE 32 IN  A:192
  STORE 32 IN  A:193
  STORE 32 IN  A:194
  STORE 32 IN  A:195
  STORE 32 IN  A:196
  STORE 32 IN  A:197
  STORE 68 IN  A:198
  STORE 73 IN  A:199
  STORE 83 IN  A:200
  STORE 80 IN  A:201
  STORE 76 IN  A:202
  STORE 65 IN  A:203
  STORE 89 IN  A:204
  STORE 32 IN  A:205
  STORE 65 IN  A:206
  STORE 58 IN  A:207
  STORE 73 IN  A:208
  STORE 10 IN  A:209
  STORE 32 IN  A:210
  STORE 32 IN  A:211
  STORE 32 IN  A:212
  STORE 32 IN  A:213
  STORE 32 IN  A:214
  STORE 32 IN  A:215
  STORE 32 IN  A:216
  STORE 32 IN  A:217
  STORE 68 IN  A:218
  STORE 73 IN  A:219
  STORE 83 IN  A:220
  STORE 80 IN  A:221
  STORE 76 IN  A:222
  STORE 65 IN  A:223
  STORE 89 IN  A:224
  STORE 32 IN  A:225
  STORE 34 IN  A:226
  STORE 32 IN  A:227
  STORE 73 IN  A:228
  STORE 78 IN  A:229
  STORE 32 IN  A:230
  STORE 34 IN  A:231
  STORE 10 IN  A:232
  STORE 32 IN  A:233
  STORE 32 IN  A:234
  STORE 32 IN  A:235
  STORE 32 IN  A:236
  STORE 32 IN  A:237
  STORE 32 IN  A:238
  STORE 32 IN  A:239
  STORE 32 IN  A:240
  STORE 68 IN  A:241
  STORE 73 IN  A:242
  STORE 83 IN  A:243
  STORE 80 IN  A:244
  STORE 76 IN  A:245
  STORE 65 IN  A:246
  STORE 89 IN  A:247
  STORE 32 IN  A:248
  STORE 34 IN  A:249
  STORE 32 IN  A:250
  STORE 65 IN  A:251
  STORE 58 IN  A:252
  STORE 34 IN  A:253
  STORE 10 IN  A:254
  STORE 32 IN  A:255
  STORE 32 IN  A:256
  STORE 32 IN  A:257
  STORE 32 IN  A:258
  STORE 32 IN  A:259
  STORE 32 IN  A:260
  STORE 32 IN  A:261
  STORE 32 IN  A:262
  STORE 68 IN  A:263
  STORE 73 IN  A:264
  STORE 83 IN  A:265
  STORE 80 IN  A:266
  STORE 76 IN  A:267
  STORE 65 IN  A:268
  STORE 89 IN  A:269
  STORE 32 IN  A:270
  STORE 73 IN  A:271
  STORE 32 IN  A:272
  STORE 67 IN  A:273
  STORE 82 IN  A:274
  STORE 76 IN  A:275
  STORE 70 IN  A:276
  STORE 10 IN  A:277
  STORE 32 IN  A:278
  STORE 32 IN  A:279
  STORE 32 IN  A:280
  STORE 32 IN  A:281
  STORE 32 IN  A:282
  STORE 32 IN  A:283
  STORE 32 IN  A:284
  STORE 32 IN  A:285
  STORE 65 IN  A:286
  STORE 68 IN  A:287
  STORE 68 IN  A:288
  STORE 32 IN  A:289
  STORE 73 IN  A:290
  STORE 32 IN  A:291
  STORE 65 IN  A:292
  STORE 78 IN  A:293
  STORE 68 IN  A:294
  STORE 32 IN  A:295
  STORE 49 IN  A:296
  STORE 32 IN  A:297
  STORE 73 IN  A:298
  STORE 78 IN  A:299
  STORE 32 IN  A:300
  STORE 73 IN  A:301
  STORE 10 IN  A:302
  STORE 32 IN  A:303
  STORE 32 IN  A:304
  STORE 32 IN  A:305
  STORE 32 IN  A:306
  STORE 82 IN  A:307
  STORE 69 IN  A:308
  STORE 80 IN  A:309
  STORE 69 IN  A:310
  STORE 65 IN  A:311
  STORE 84 IN  A:312
  STORE 10 IN  A:313
  STORE 32 IN  A:314
  STORE 32 IN  A:315
  STORE 32 IN  A:316
  STORE 32 IN  A:317
  STORE 68 IN  A:318
  STORE 73 IN  A:319
  STORE 83 IN  A:320
  STORE 80 IN  A:321
  STORE 76 IN  A:322
  STORE 65 IN  A:323
  STORE 89 IN  A:324
  STORE 32 IN  A:325
  STORE 34 IN  A:326
  STORE 32 IN  A:327
  STORE 32 IN  A:328
  STORE 83 IN  A:329
  STORE 84 IN  A:330
  STORE 79 IN  A:331
  STORE 82 IN  A:332
  STORE 69 IN  A:333
  STORE 32 IN  A:334
  STORE 34 IN  A:335
  STORE 10 IN  A:336
  STORE 32 IN  A:337
  STORE 32 IN  A:338
  STORE 32 IN  A:339
  STORE 32 IN  A:340
  STORE 68 IN  A:341
  STORE 73 IN  A:342
  STORE 83 IN  A:343
  STORE 80 IN  A:344
  STORE 76 IN  A:345
  STORE 65 IN  A:346
  STORE 89 IN  A:347
  STORE 32 IN  A:348
  STORE 78 IN  A:349
  STORE 10 IN  A:350
  STORE 32 IN  A:351
  STORE 32 IN  A:352
  STORE 32 IN  A:353
  STORE 32 IN  A:354
  STORE 68 IN  A:355
  STORE 73 IN  A:356
  STORE 83 IN  A:357
  STORE 80 IN  A:358
  STORE 76 IN  A:359
  STORE 65 IN  A:360
  STORE 89 IN  A:361
  STORE 32 IN  A:362
  STORE 34 IN  A:363
  STORE 32 IN  A:364
  STORE 73 IN  A:365
  STORE 78 IN  A:366
  STORE 32 IN  A:367
  STORE 78 IN  A:368
  STORE 34 IN  A:369
  STORE 32 IN  A:370
  STORE 67 IN  A:371
  STORE 82 IN  A:372
  STORE 76 IN  A:373
  STORE 70 IN  A:374
  STORE 10 IN  A:375
  STORE 32 IN  A:376
  STORE 32 IN  A:377
  STORE 69 IN  A:378
  STORE 78 IN  A:379
  STORE 68 IN  A:380
  STORE 32 IN  A:381
  STORE 83 IN  A:382
  STORE 85 IN  A:383
  STORE 66 IN  A:384
  STORE 45 IN  A:385
  STORE 80 IN  A:386
  STORE 82 IN  A:387
  STORE 79 IN  A:388
  STORE 67 IN  A:389
  STORE 69 IN  A:390
  STORE 68 IN  A:391
  STORE 85 IN  A:392
  STORE 82 IN  A:393
  STORE 69 IN  A:394
  STORE 10 IN  A:395
  STORE 10 IN  A:396
  STORE 32 IN  A:397
  STORE 32 IN  A:398
  STORE 83 IN  A:399
  STORE 85 IN  A:400
  STORE 66 IN  A:401
  STORE 45 IN  A:402
  STORE 80 IN  A:403
  STORE 82 IN  A:404
  STORE 79 IN  A:405
  STORE 67 IN  A:406
  STORE 69 IN  A:407
  STORE 68 IN  A:408
  STORE 85 IN  A:409
  STORE 82 IN  A:410
  STORE 69 IN  A:411
  STORE 32 IN  A:412
  STORE 83 IN  A:413
  STORE 72 IN  A:414
  STORE 79 IN  A:415
  STORE 87 IN  A:416
  STORE 10 IN  A:417
  STORE 32 IN  A:418
  STORE 32 IN  A:419
  STORE 32 IN  A:420
  STORE 32 IN  A:421
  STORE 83 IN  A:422
  STORE 84 IN  A:423
  STORE 79 IN  A:424
  STORE 82 IN  A:425
  STORE 69 IN  A:426
  STORE 32 IN  A:427
  STORE 48 IN  A:428
  STORE 32 IN  A:429
  STORE 73 IN  A:430
  STORE 78 IN  A:431
  STORE 32 IN  A:432
  STORE 74 IN  A:433
  STORE 10 IN  A:434
  STORE 32 IN  A:435
  STORE 32 IN  A:436
  STORE 32 IN  A:437
  STORE 32 IN  A:438
  STORE 87 IN  A:439
  STORE 72 IN  A:440
  STORE 73 IN  A:441
  STORE 76 IN  A:442
  STORE 69 IN  A:443
  STORE 32 IN  A:444
  STORE 74 IN  A:445
  STORE 32 IN  A:446
  STORE 73 IN  A:447
  STORE 83 IN  A:448
  STORE 32 IN  A:449
  STORE 76 IN  A:450
  STORE 69 IN  A:451
  STORE 83 IN  A:452
  STORE 83 IN  A:453
  STORE 32 IN  A:454
  STORE 84 IN  A:455
  STORE 72 IN  A:456
  STORE 65 IN  A:457
  STORE 78 IN  A:458
  STORE 32 IN  A:459
  STORE 78 IN  A:460
  STORE 32 IN  A:461
  STORE 68 IN  A:462
  STORE 79 IN  A:463
  STORE 10 IN  A:464
  STORE 32 IN  A:465
  STORE 32 IN  A:466
  STORE 32 IN  A:467
  STORE 32 IN  A:468
  STORE 32 IN  A:469
  STORE 32 IN  A:470
  STORE 32 IN  A:471
  STORE 32 IN  A:472
  STORE 73 IN  A:473
  STORE 70 IN  A:474
  STORE 32 IN  A:475
  STORE 65 IN  A:476
  STORE 58 IN  A:477
  STORE 74 IN  A:478
  STORE 32 IN  A:479
  STORE 73 IN  A:480
  STORE 83 IN  A:481
  STORE 32 IN  A:482
  STORE 69 IN  A:483
  STORE 81 IN  A:484
  STORE 85 IN  A:485
  STORE 65 IN  A:486
  STORE 76 IN  A:487
  STORE 32 IN  A:488
  STORE 84 IN  A:489
  STORE 79 IN  A:490
  STORE 32 IN  A:491
  STORE 52 IN  A:492
  STORE 50 IN  A:493
  STORE 32 IN  A:494
  STORE 84 IN  A:495
  STORE 72 IN  A:496
  STORE 69 IN  A:497
  STORE 78 IN  A:498
  STORE 10 IN  A:499
  STORE 32 IN  A:500
  STORE 32 IN  A:501
  STORE 32 IN  A:502
  STORE 32 IN  A:503
  STORE 32 IN  A:504
  STORE 32 IN  A:505
  STORE 32 IN  A:506
  STORE 32 IN  A:507
  STORE 32 IN  A:508
  STORE 32 IN  A:509
  STORE 67 IN  A:510
  STORE 65 IN  A:511
  STORE 76 IN  A:512
  STORE 76 IN  A:513
  STORE 32 IN  A:514
  STORE 83 IN  A:515
  STORE 85 IN  A:516
  STORE 66 IN  A:517
  STORE 45 IN  A:518
  STORE 80 IN  A:519
  STORE 82 IN  A:520
  STORE 79 IN  A:521
  STORE 67 IN  A:522
  STORE 69 IN  A:523
  STORE 68 IN  A:524
  STORE 85 IN  A:525
  STORE 82 IN  A:526
  STORE 69 IN  A:527
  STORE 32 IN  A:528
  STORE 83 IN  A:529
  STORE 72 IN  A:530
  STORE 79 IN  A:531
  STORE 87 IN  A:532
  STORE 85 IN  A:533
  STORE 10 IN  A:534
  STORE 32 IN  A:535
  STORE 32 IN  A:536
  STORE 32 IN  A:537
  STORE 32 IN  A:538
  STORE 32 IN  A:539
  STORE 32 IN  A:540
  STORE 32 IN  A:541
  STORE 32 IN  A:542
  STORE 69 IN  A:543
  STORE 76 IN  A:544
  STORE 83 IN  A:545
  STORE 69 IN  A:546
  STORE 10 IN  A:547
  STORE 32 IN  A:548
  STORE 32 IN  A:549
  STORE 32 IN  A:550
  STORE 32 IN  A:551
  STORE 32 IN  A:552
  STORE 32 IN  A:553
  STORE 32 IN  A:554
  STORE 32 IN  A:555
  STORE 32 IN  A:556
  STORE 32 IN  A:557
  STORE 83 IN  A:558
  STORE 84 IN  A:559
  STORE 79 IN  A:560
  STORE 82 IN  A:561
  STORE 69 IN  A:562
  STORE 32 IN  A:563
  STORE 67 IN  A:564
  STORE 72 IN  A:565
  STORE 65 IN  A:566
  STORE 82 IN  A:567
  STORE 65 IN  A:568
  STORE 67 IN  A:569
  STORE 84 IN  A:570
  STORE 69 IN  A:571
  STORE 82 IN  A:572
  STORE 32 IN  A:573
  STORE 65 IN  A:574
  STORE 58 IN  A:575
  STORE 74 IN  A:576
  STORE 32 IN  A:577
  STORE 73 IN  A:578
  STORE 78 IN  A:579
  STORE 32 IN  A:580
  STORE 67 IN  A:581
  STORE 10 IN  A:582
  STORE 32 IN  A:583
  STORE 32 IN  A:584
  STORE 32 IN  A:585
  STORE 32 IN  A:586
  STORE 32 IN  A:587
  STORE 32 IN  A:588
  STORE 32 IN  A:589
  STORE 32 IN  A:590
  STORE 32 IN  A:591
  STORE 32 IN  A:592
  STORE 68 IN  A:593
  STORE 73 IN  A:594
  STORE 83 IN  A:595
  STORE 80 IN  A:596
  STORE 76 IN  A:597
  STORE 65 IN  A:598
  STORE 89 IN  A:599
  STORE 32 IN  A:600
  STORE 67 IN  A:601
  STORE 10 IN  A:602
  STORE 32 IN  A:603
  STORE 32 IN  A:604
  STORE 32 IN  A:605
  STORE 32 IN  A:606
  STORE 32 IN  A:607
  STORE 32 IN  A:608
  STORE 32 IN  A:609
  STORE 32 IN  A:610
  STORE 69 IN  A:611
  STORE 78 IN  A:612
  STORE 68 IN  A:613
  STORE 45 IN  A:614
  STORE 73 IN  A:615
  STORE 70 IN  A:616
  STORE 10 IN  A:617
  STORE 32 IN  A:618
  STORE 32 IN  A:619
  STORE 32 IN  A:620
  STORE 32 IN  A:621
  STORE 32 IN  A:622
  STORE 32 IN  A:623
  STORE 32 IN  A:624
  STORE 32 IN  A:625
  STORE 65 IN  A:626
  STORE 68 IN  A:627
  STORE 68 IN  A:628
  STORE 32 IN  A:629
  STORE 74 IN  A:630
  STORE 32 IN  A:631
  STORE 65 IN  A:632
  STORE 78 IN  A:633
  STORE 68 IN  A:634
  STORE 32 IN  A:635
  STORE 49 IN  A:636
  STORE 32 IN  A:637
  STORE 73 IN  A:638
  STORE 78 IN  A:639
  STORE 32 IN  A:640
  STORE 74 IN  A:641
  STORE 10 IN  A:642
  STORE 32 IN  A:643
  STORE 32 IN  A:644
  STORE 32 IN  A:645
  STORE 32 IN  A:646
  STORE 82 IN  A:647
  STORE 69 IN  A:648
  STORE 80 IN  A:649
  STORE 69 IN  A:650
  STORE 65 IN  A:651
  STORE 84 IN  A:652
  STORE 10 IN  A:653
  STORE 32 IN  A:654
  STORE 32 IN  A:655
  STORE 69 IN  A:656
  STORE 78 IN  A:657
  STORE 68 IN  A:658
  STORE 32 IN  A:659
  STORE 83 IN  A:660
  STORE 85 IN  A:661
  STORE 66 IN  A:662
  STORE 45 IN  A:663
  STORE 80 IN  A:664
  STORE 82 IN  A:665
  STORE 79 IN  A:666
  STORE 67 IN  A:667
  STORE 69 IN  A:668
  STORE 68 IN  A:669
  STORE 85 IN  A:670
  STORE 82 IN  A:671
  STORE 69 IN  A:672
  STORE 10 IN  A:673
  STORE 10 IN  A:674
  STORE 42 IN  A:675
  STORE 10 IN  A:676
  STORE 32 IN  A:677
  STORE 32 IN  A:678
  STORE 67 IN  A:679
  STORE 65 IN  A:680
  STORE 76 IN  A:681
  STORE 76 IN  A:682
  STORE 32 IN  A:683
  STORE 83 IN  A:684
  STORE 85 IN  A:685
  STORE 66 IN  A:686
  STORE 45 IN  A:687
  STORE 80 IN  A:688
  STORE 82 IN  A:689
  STORE 79 IN  A:690
  STORE 67 IN  A:691
  STORE 69 IN  A:692
  STORE 68 IN  A:693
  STORE 85 IN  A:694
  STORE 82 IN  A:695
  STORE 69 IN  A:696
  STORE 32 IN  A:697
  STORE 83 IN  A:698
  STORE 72 IN  A:699
  STORE 79 IN  A:700
  STORE 87 IN  A:701
  STORE 10 IN  A:702
  STORE 10 IN  A:703
  STORE 704 IN N

  CALL SUB-PROCEDURE SHOW


((lambda (x) (list x (list 'quote x)))
  '(lambda (x) (list x (list 'quote x))))


Module Alfa {
	Rem {This Program Show itself in Help Form}
	inline "help "+quote$(module.name$)
}
Alfa


/* Using ?format from the unerlying Lisp system */

lambda([],block([q:ascii(34),s:"lambda([],block([q:ascii(34),s:~A~A~A],print(?format(false,s,q,s,q))))()$"],print(?format(false,s,q,s,q))))()$


MODULE Quine;
FROM FormatString IMPORT FormatString;
FROM Terminal IMPORT WriteString,ReadChar;

CONST src = "MODULE Quine;\nFROM FormatString IMPORT FormatString;\nFROM Terminal IMPORT WriteString,ReadChar;\n\nCONST src = \x022%s\x022;\nVAR buf : ARRAY[0..2048] OF CHAR;\nBEGIN\n    FormatString(src, buf, src);\n    WriteString(buf);\n    ReadChar\nEND Quine.\n";
VAR buf : ARRAY[0..2048] OF CHAR;
BEGIN
    FormatString(src, buf, src);
    WriteString(buf);
    ReadChar
END Quine.


QUINE
 NEW I,L SET I=0
 FOR  SET I=I+1,L=$TEXT(+I) Q:L=""  WRITE $TEXT(+I),!
 KILL I,L
 QUIT

SMALL
 S %=0 F  W $T(+$I(%)),! Q:$T(+%)=""


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

Q = "'"
S = "\\"
N = "\n"
A = "&"
code = [ -
  '/* NetRexx */', -
  'options replace format comments java crossref savelog symbols nobinary', -
  '', -
  'Q = "&QS"', -
  'S = "&ESC"', -
  'N = "&NL"', -
  'A = "&AMP"', -
  'code = [ -', -
  '&REP', -
  '  ]', -
  '', -
  'pgm = ""', -
  'txt = ""', -
  'loop t_ = 0 for code.length', -
  '  txt = txt || "  " || Q || code[t_] || Q || ", -" || N', -
  '  end t_', -
  'txt = txt.strip("T", N)', -
  'txt = txt.delstr(txt.lastpos(","), 1)', -
  '', -
  'K = ""', -
  'K[0] = 5', -
  'K[1] = A"NL"', -
  'K[2] = A"AMP"', -
  'K[3] = A"ESC"', -
  'K[4] = A"QS"', -
  'K[5] = A"REP"', -
  'loop c_ = 0 for code.length', -
  '  loop v_ = 1 to K[0]', -
  '    T = K[v_]', -
  '    if code[c_].pos(T) <> 0 then do', -
  '      parse code[c_] pre(T)post', -
  '      select case T', -
  '        when K[1] then do', -
  '          code[c_] = pre || S || "n" || post', -
  '          end', -
  '        when K[2] then do', -
  '          code[c_] = pre || A || post', -
  '          end', -
  '        when K[3] then do', -
  '          code[c_] = pre || S || S || post', -
  '          end', -
  '        when K[4] then do', -
  '          code[c_] = pre || Q || post', -
  '          end', -
  '        when K[5] then do', -
  '          code[c_] = txt', -
  '          end', -
  '        otherwise nop', -
  '        end', -
  '      end', -
  '    end v_', -
  '  pgm = pgm || code[c_].strip("T") || N', -
  '  end c_', -
  'pgm = pgm.strip("T", N) || N', -
  'say pgm', -
  '', -
  'return', -
  '' -
  ]

pgm = ""
txt = ""
loop t_ = 0 for code.length
  txt = txt || "  " || Q || code[t_] || Q || ", -" || N
  end t_
txt = txt.strip("T", N)
txt = txt.delstr(txt.lastpos(","), 1)

K = ""
K[0] = 5
K[1] = A"NL"
K[2] = A"AMP"
K[3] = A"ESC"
K[4] = A"QS"
K[5] = A"REP"
loop c_ = 0 for code.length
  loop v_ = 1 to K[0]
    T = K[v_]
    if code[c_].pos(T) <> 0 then do
      parse code[c_] pre(T)post
      select case T
        when K[1] then do
          code[c_] = pre || S || "n" || post
          end
        when K[2] then do
          code[c_] = pre || A || post
          end
        when K[3] then do
          code[c_] = pre || S || S || post
          end
        when K[4] then do
          code[c_] = pre || Q || post
          end
        when K[5] then do
          code[c_] = txt
          end
        otherwise nop
        end
      end
    end v_
  pgm = pgm || code[c_].strip("T") || N
  end c_
pgm = pgm.strip("T", N) || N
say pgm

return


(lambda (s) (print (list s (list 'quote s))))


MODULE M;
 IMPORT O:=Out;
 CONST
  T=";PROCEDURE c*;BEGIN O.Char(22X);O.String(T) END c;BEGIN O.String('MODULE M;IMPORT O:=Out;CONST T=');c END M.";

 PROCEDURE c*;
 BEGIN
  O.Char(22X);O.String(T)
 END c;

BEGIN
 O.String('MODULE M;IMPORT O:=Out;CONST T=');
 c
END M.


class Program { function : Main(args : String[]) ~ Nil { s := "class Program { function : Main(args : String[]) ~ Nil { s :=;  IO.Console->Print(s->SubString(61))->Print(34->As(Char))->Print(s)->Print(34->As(Char))->PrintLine(s->SubString(61, 129)); } }";  IO.Console->Print(s->SubString(61))->Print(34->As(Char))->Print(s)->Print(34->As(Char))->PrintLine(s->SubString(61, 129)); } }


(fun p -> Printf.printf p (string_of_format p)) "(fun p -> Printf.printf p (string_of_format p)) %S;;\n";;


T FIFO
   [Int] contents

   F push(item)
      .contents.append(item)
   F pop()
      R .contents.pop(0)
   F empty()
      R .contents.empty

V f = FIFO()
f.push(3)
f.push(2)
f.push(1)
L !f.empty()
   print(f.pop())


"dup 34 emit print 34 emit BL emit print" dup 34 emit print 34 emit BL emit print


((lambda (s) (display (list s (list (quote quote) s)))) (quote (lambda (s) (display (list s (list (quote quote) s))))))


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  program defqueue64.s   */

/*******************************************/
/* Constantes file                         */
/*******************************************/
/* for this file see task include a file in language AArch64 assembly*/
.include "../includeConstantesARM64.inc"

.equ  NBMAXIELEMENTS,    100

/*******************************************/
/* Structures                               */
/********************************************/
/* example structure  for value of item  */
    .struct  0
value_ident:                     // ident
    .struct  value_ident + 8
value_value1:                    // value 1
    .struct  value_value1 + 8
value_value2:                    // value 2
    .struct  value_value2 + 8
value_fin:
/* example structure  for queue  */
    .struct  0
queue_ptdeb:                     // begin pointer of item
    .struct  queue_ptdeb + 8
queue_ptfin:                     // end pointer of item
    .struct  queue_ptfin + 8
queue_stvalue:                   // structure of value item
    .struct  queue_stvalue + (value_fin * NBMAXIELEMENTS)
queue_fin:

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessEmpty:       .asciz "Empty queue. \n"
szMessNotEmpty:    .asciz "Not empty queue. \n"
szMessError:       .asciz "Error detected !!!!. \n"
szMessResult:      .asciz "Ident : @ value 1 : @ value 2 : @ \n"  // message result

szCarriageReturn:  .asciz "\n"
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
.align 4
Queue1:                .skip queue_fin      // queue memory place
stItem:                .skip value_fin      // value item memory place
sZoneConv:             .skip 100
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                       // entry of program
    ldr x0,qAdrQueue1                       // queue structure address
    bl isEmpty
    cmp x0,#0
    beq 1f
    ldr x0,qAdrszMessEmpty
    bl affichageMess                        // display message empty
    b 2f
1:
    ldr x0,qAdrszMessNotEmpty
    bl affichageMess                        // display message not empty
2:
    // init item 1
    ldr x0,qAdrstItem
    mov x1,#1
    str x1,[x0,#value_ident]
    mov x1,#11
    str x1,[x0,#value_value1]
    mov x1,#12
    str x1,[x0,#value_value2]

    ldr x0,qAdrQueue1                       // queue structure address
    ldr x1,qAdrstItem
    bl pushQueue                            // add item in queue
    cmp x0,#-1                              // error ?
    beq 99f
    // init item 2
    ldr x0,qAdrstItem
    mov x1,#2
    str x1,[x0,#value_ident]
    mov x1,#21
    str x1,[x0,#value_value1]
    mov x1,#22
    str x1,[x0,#value_value2]

    ldr x0,qAdrQueue1                       // queue structure address
    ldr x1,qAdrstItem
    bl pushQueue                            // add item in queue
    cmp x0,#-1
    beq 99f
    ldr x0,qAdrQueue1                       // queue structure address
    bl isEmpty
    cmp x0,#0                               // not empty
    beq 3f
    ldr x0,qAdrszMessEmpty
    bl affichageMess                        // display message empty
    b 4f
3:
    ldr x0,qAdrszMessNotEmpty
    bl affichageMess                        // display message not empty

4:
    ldr x0,qAdrQueue1                       // queue structure address
    bl popQueue                             // return address item
    cmp x0,#-1                              // error ?
    beq 99f
    mov x2,x0                               // save item pointer
    ldr x0,[x2,#value_ident]
    ldr x1,qAdrsZoneConv                    // conversion ident
    bl conversion10S                        // decimal conversion
    ldr x0,qAdrszMessResult
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc                   // insert result at first @ character
    mov x5,x0
    ldr x0,[x2,#value_value1]
    ldr x1,qAdrsZoneConv                    // conversion value 1
    bl conversion10S                        // decimal conversion
    mov x0,x5
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc                   // insert result at Second @ character
    mov x5,x0
    ldr x0,[x2,#value_value2]
    ldr x1,qAdrsZoneConv                    // conversion value 2
    bl conversion10S                        // decimal conversion
    mov x0,x5
    ldr x1,qAdrsZoneConv
    bl strInsertAtCharInc                   // insert result at third @ character
    bl affichageMess                        // display message final
    b 4b                                    // loop

99:                                         // error
    ldr x0,qAdrszMessError
    bl affichageMess
100:                                        // standard end of the program
    mov x0,0                                // return code
    mov x8,EXIT                             // request to exit program
    svc 0                                   // perform the system call

qAdrQueue1:               .quad Queue1
qAdrstItem:               .quad stItem
qAdrszMessError:          .quad szMessError
qAdrszMessEmpty:          .quad szMessEmpty
qAdrszMessNotEmpty:       .quad szMessNotEmpty
qAdrszMessResult:         .quad szMessResult
qAdrszCarriageReturn:     .quad szCarriageReturn
qAdrsZoneConv:            .quad sZoneConv

/******************************************************************/
/*     test if queue empty                                        */
/******************************************************************/
/* x0 contains the address of queue structure */
/* x0 returns 0 if not empty, 1 if empty    */
isEmpty:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    ldr x1,[x0,#queue_ptdeb]       // begin pointer
    ldr x2,[x0,#queue_ptfin]       // begin pointer
    cmp x1,x2
    bne 1f
    mov x0,#1                      // empty queue
    b 2f
1:
    mov x0,#0                      // not empty
2:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30

/******************************************************************/
/*     add item  in queue                                         */
/******************************************************************/
/* x0 contains the address of queue structure */
/* x1 contains the address of item            */
pushQueue:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    add x2,x0,#queue_stvalue       // address of values structure
    ldr x3,[x0,#queue_ptfin]       // end pointer
    add x2,x2,x3                      // free address of queue
    ldr x4,[x1,#value_ident]       // load ident item
    str x4,[x2,#value_ident]       // and store in queue
    ldr x4,[x1,#value_value1]      // idem
    str x4,[x2,#value_value1]
    ldr x4,[x1,#value_value2]
    str x4,[x2,#value_value2]
    add x3,x3,#value_fin
    cmp x3,#value_fin * NBMAXIELEMENTS
    beq 99f
    str x3,[x0,#queue_ptfin]       // store new end pointer
    b 100f
99:
    mov x0,#-1                     // error
100:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30

/******************************************************************/
/*     pop queue                                                  */
/******************************************************************/
/* x0 contains the address of queue structure */
popQueue:
    stp x1,lr,[sp,-16]!            // save  registers
    stp x2,x3,[sp,-16]!            // save  registers
    mov x1,x0                      // control if empty queue
    bl isEmpty
    cmp x0,#1                      // yes -> error
    beq 99f
    mov x0,x1
    ldr x1,[x0,#queue_ptdeb]       // begin pointer
    add x2,x0,#queue_stvalue       // address of begin values item
    add x2,x2,x1                   // address of item
    add x1,x1,#value_fin
    str x1,[x0,#queue_ptdeb]       // store nex begin pointer
    mov x0,x2                      // return pointer item
    b 100f
99:
    mov x0,#-1                     // error
100:
    ldp x2,x3,[sp],16              // restaur  2 registers
    ldp x1,lr,[sp],16              // restaur  2 registers
    ret                            // return to address lr x30

/********************************************************/
/*        File Include fonctions                        */
/********************************************************/
/* for this file see task include a file in language AArch64 assembly */
.include "../includeARM64.inc"


(defun enqueue (x xs)
   (cons x xs))

(defun dequeue (xs)
   (declare (xargs :guard (and (consp xs)
                               (true-listp xs))))
   (if (or (endp xs) (endp (rest xs)))
       (mv (first xs) nil)
       (mv-let (x ys)
               (dequeue (rest xs))
          (mv x (cons (first xs) ys)))))

(defun empty (xs)
   (endp xs))


'RUNTIME COMPILING

source="print source"

a=compile source : call a : freememory a


DEFINE MAXSIZE="200"
BYTE ARRAY queue(MAXSIZE)
BYTE queueFront=[0],queueRear=[0]

BYTE FUNC IsEmpty()
  IF queueFront=queueRear THEN
    RETURN (1)
  FI
RETURN (0)

PROC Push(BYTE v)
  BYTE rear

  rear=queueRear+1
  IF rear=MAXSIZE THEN
    rear=0
  FI
  IF rear=queueFront THEN
    PrintE("Error: queue is full!")
    Break()
  FI
  queue(queueRear)=v
  queueRear=rear
RETURN

BYTE FUNC Pop()
  BYTE v

  IF IsEmpty() THEN
    PrintE("Error: queue is empty!")
    Break()
  FI
  v=queue(queueFront)
  queueFront==+1
  IF queueFront=MAXSIZE THEN
    queueFront=0
  FI
RETURN (v)

PROC TestIsEmpty()
  IF IsEmpty() THEN
    PrintE("Queue is empty")
  ELSE
    PrintE("Queue is not empty")
  FI
RETURN

PROC TestPush(BYTE v)
  PrintF("Push: %B%E",v)
  Push(v)
RETURN

PROC TestPop()
  BYTE v

  Print("Pop: ")
  v=Pop()
  PrintBE(v)
RETURN

PROC Main()
  TestIsEmpty()
  TestPush(10)
  TestIsEmpty()
  TestPush(31)
  TestPop()
  TestIsEmpty()
  TestPush(5)
  TestPop()
  TestPop()
  TestPop()
RETURN


generic
   type Element_Type is private;
package Fifo is
   type Fifo_Type is private;
   procedure Push(List : in out Fifo_Type; Item : in Element_Type);
   procedure Pop(List : in out Fifo_Type; Item : out Element_Type);
   function Is_Empty(List : Fifo_Type) return Boolean;
   Empty_Error : exception;
private
   type Fifo_Element;
   type Fifo_Ptr is access Fifo_Element;
   type Fifo_Type is record
      Head : Fifo_Ptr := null;
      Tail : Fifo_Ptr := null;
   end record;
   type Fifo_Element is record
      Value : Element_Type;
      Next  : Fifo_Ptr := null;
   end record;
end Fifo;


declare I in thread {System.showInfo I#[34]#I#[34]} end I ="declare I in thread {System.showInfo I#[34]#I#[34]} end I ="


# -*- coding: utf-8 -*- #
CO REQUIRES:
  MODE OBJLINK = STRUCT(
    REF OBJLINK next,
    REF OBJLINK prev,
    OBJVALUE value # ... etc. required #
  );
  PROC obj link new = REF OBJLINK: ~;
  PROC obj link free = (REF OBJLINK free)VOID: ~
END CO

# actually a pointer to the last LINK, there ITEMs are ADDED/get #
MODE OBJQUEUE = REF OBJLINK;

OBJQUEUE obj queue empty = NIL;

BOOL obj queue par = FALSE; # make code thread safe #
SEMA obj queue sema = LEVEL ABS obj queue par;
# Warning: 1 SEMA for all queues of type obj, i.e. not 1 SEMA per queue #

PROC obj queue init = (REF OBJQUEUE self)REF OBJQUEUE:
  self := obj queue empty;

PROC obj queue put = (REF OBJQUEUE self, OBJVALUE obj)REF OBJQUEUE: (
  REF OBJLINK out = obj link new;
  IF obj queue par THEN DOWN obj queue sema FI;
  IF self IS obj queue empty THEN
    out := (out, out, obj) # self referal #
  ELSE # join into list #
    out := (self, prev OF self, obj);
    next OF prev OF out := prev OF next OF out := out
  FI;
  IF obj queue par THEN UP obj queue sema FI;
  self := out
);

# define a useful prepend/put/plusto (+=:) operator... #
PROC obj queue plusto = (OBJVALUE obj, REF OBJQUEUE self)OBJQUEUE: obj queue put(self,obj);
OP +=: = (OBJVALUE obj, REF OBJQUEUE self)REF OBJQUEUE: obj queue put(self,obj);
# a potential append/plusab (+:=) operator...
OP (REF OBJQUEUE, OBJVALUE)OBJQUEUE +:= = obj queue plusab;
#

# see if the program/coder wants the OBJ problem mended... #
PROC (REF OBJQUEUE #self#)BOOL obj queue index error mended
  := (REF OBJQUEUE self)BOOL: (abend("obj queue index error"); stop);

PROC on obj queue index error = (REF OBJQUEUE self, PROC(REF OBJQUEUE #self#)BOOL mended)VOID:
  obj queue index error mended := mended;

PROC obj queue get = (REF OBJQUEUE self)OBJVALUE: (
# DOWN obj queue sema; #
  IF self IS obj queue empty THEN
    IF NOT obj queue index error mended(self) THEN abend("obj stack index error") FI FI;
  OBJQUEUE old tail = prev OF self;
  IF old tail IS self THEN # free solo member #
    self := obj queue empty
  ELSE # free self/tail member #
    OBJQUEUE new tail = prev OF old tail;
    next OF new tail := self;
    prev OF self := new tail
  FI;
#;UP obj queue sema #
  OBJVALUE out = value OF old tail;
# give a recovery hint to the garbage collector #
  obj link free(old tail);
  out
);

PROC obj queue is empty = (REF OBJQUEUE self)BOOL:
  self IS obj queue empty;

SKIP


begin
    % define a Queue type that will hold StringQueueElements %
    record StringQueue ( reference(StringQueueElement) front, back );
    % define the StringQueueElement type %
    record StringQueueElement ( string(8)                     element
                              ; reference(StringQueueElement) next
                              );
    % we would need separate types for other element types   %
    % adds s to the end of the StringQueue q                 %
    procedure pushString ( reference(StringQueue) value q
                         ; string(8)              value e
                         ) ;
    begin
        reference(StringQueueElement) newElement;
        newElement := StringQueueElement( e, null );
        if front(q) = null then begin
            % adding to an empty queue %
            front(q) := newElement;
            back(q)  := newElement
            end
        else begin
            % the queue is not empty %
            next(back(q)) := newElement;
            back(q)       := newElement
        end
    end pushString ;
    % removes an element from the front of the StringQueue q %
    % asserts the queue is not empty, which will stop the    %
    % program if it is                                       %
    string(8) procedure popString ( reference(StringQueue) value q ) ;
    begin
        string(8) v;
        assert( not isEmptyStringQueue( q ) );
        v        := element(front(q));
        front(q) := next(front(q));
        if front(q) = null then % just popped the last element % back(q) := null;
        v
    end popStringQueue ;
    % returns true if the StringQueue q is empty, false otherwise %
    logical procedure isEmptyStringQueue ( reference(StringQueue) value q ) ; front(q) = null;

    begin % test the StringQueue operations %
        reference(StringQueue) q;
        q := StringQueue( null, null );
        pushString( q, "fred"   );
        pushString( q, "whilma" );
        pushString( q, "betty"  );
        pushString( q, "barney" );
        while not isEmptyStringQueue( q ) do write( popString( q ) )
    end
end.


 0  DEF  FN E(MPTY) = SP = FIRST
 10  GOSUB 150EMPTY
 20  LET A$ = "A": GOSUB 100PUSH
 30  LET A$ = "B": GOSUB 100PUSH
 40  GOSUB 150EMPTY
 50  GOSUB 120PULL FIRST
 60  GOSUB 120PULL FIRST
 70  GOSUB 150EMPTY
 80  GOSUB 120PULL FIRST
 90  END
 100  PRINT "PUSH "A$
 110  LET S$(SP) = A$:SP = SP + 1: RETURN
 120  GOSUB 130: PRINT "POP "A$: RETURN
 130  IF  FN E(0) THEN  PRINT "POPPING FROM EMPTY QUEUE";: STOP
 140  A$ = S$(FI): FI = FI + 1 : RETURN
 150  PRINT "EMPTY? " MID$ ("YESNO",4 ^  FN E(0),3): RETURN


('((X) (list (lit X) (lit X))) '((X) (list (lit X) (lit X))))


/* ARM assembly Raspberry PI  */
/*  program defqueue.s   */

/* Constantes    */
.equ STDOUT, 1     @ Linux output console
.equ EXIT,   1     @ Linux syscall
.equ WRITE,  4     @ Linux syscall

.equ  NBMAXIELEMENTS,    100

/*******************************************/
/* Structures                               */
/********************************************/
/* example structure  for value of item  */
    .struct  0
value_ident:                     @ ident
    .struct  value_ident + 4
value_value1:                    @ value 1
    .struct  value_value1 + 4
value_value2:                    @ value 2
    .struct  value_value2 + 4
value_fin:
/* example structure  for queue  */
    .struct  0
queue_ptdeb:                     @ begin pointer of item
    .struct  queue_ptdeb + 4
queue_ptfin:                     @ end pointer of item
    .struct  queue_ptfin + 4
queue_stvalue:                   @ structure of value item
    .struct  queue_stvalue + (value_fin * NBMAXIELEMENTS)
queue_fin:

/*********************************/
/* Initialized data              */
/*********************************/
.data
szMessEmpty:       .asciz "Empty queue. \n"
szMessNotEmpty:    .asciz "Not empty queue. \n"
szMessError:       .asciz "Error detected !!!!. \n"
szMessResult:      .ascii "Ident :"                    @ message result
sMessIdent:        .fill 11, 1, ' '
                    .ascii " value 1 :"
sMessValue1:       .fill 11, 1, ' '
                    .ascii " value 2 :"
sMessValue2:       .fill 11, 1, ' '
                    .asciz "\n"

szCarriageReturn:  .asciz "\n"
/*********************************/
/* UnInitialized data            */
/*********************************/
.bss
.align 4
Queue1:                .skip queue_fin      @ queue memory place
stItem:                .skip value_fin      @ value item memory place
/*********************************/
/*  code section                 */
/*********************************/
.text
.global main
main:                                       @ entry of program
    ldr r0,iAdrQueue1                       @ queue structure address
    bl isEmpty
    cmp r0,#0
    beq 1f
    ldr r0,iAdrszMessEmpty
    bl affichageMess                        @ display message empty
    b 2f
1:
    ldr r0,iAdrszMessNotEmpty
    bl affichageMess                        @ display message not empty
2:
    @ init item 1
    ldr r0,iAdrstItem
    mov r1,#1
    str r1,[r0,#value_ident]
    mov r1,#11
    str r1,[r0,#value_value1]
    mov r1,#12
    str r1,[r0,#value_value2]

    ldr r0,iAdrQueue1                       @ queue structure address
    ldr r1,iAdrstItem
    bl pushQueue                            @ add item in queue
    cmp r0,#-1                              @ error ?
    beq 99f
    @ init item 2
    ldr r0,iAdrstItem
    mov r1,#2
    str r1,[r0,#value_ident]
    mov r1,#21
    str r1,[r0,#value_value1]
    mov r1,#22
    str r1,[r0,#value_value2]

    ldr r0,iAdrQueue1                       @ queue structure address
    ldr r1,iAdrstItem
    bl pushQueue                            @ add item in queue
    cmp r0,#-1
    beq 99f
    ldr r0,iAdrQueue1                       @ queue structure address
    bl isEmpty
    cmp r0,#0                               @ not empty
    beq 3f
    ldr r0,iAdrszMessEmpty
    bl affichageMess                        @ display message empty
    b 4f
3:
    ldr r0,iAdrszMessNotEmpty
    bl affichageMess                        @ display message not empty

4:
    ldr r0,iAdrQueue1                       @ queue structure address
    bl popQueue                             @ return address item
    cmp r0,#-1                              @ error ?
    beq 99f
    mov r2,r0                               @ save item pointer
    ldr r0,[r2,#value_ident]
    ldr r1,iAdrsMessIdent                   @ display ident
    bl conversion10                         @ decimal conversion
    ldr r0,[r2,#value_value1]
    ldr r1,iAdrsMessValue1                  @ display value 1
    bl conversion10                         @ decimal conversion
    ldr r0,[r2,#value_value2]
    ldr r1,iAdrsMessValue2                  @ display value 2
    bl conversion10                         @ decimal conversion
    ldr r0,iAdrszMessResult
    bl affichageMess                        @ display message
    b 4b                                    @ loop

99:
    @ error
    ldr r0,iAdrszMessError
    bl affichageMess
100:                                        @ standard end of the program
    mov r0, #0                              @ return code
    mov r7, #EXIT                           @ request to exit program
    svc #0                                  @ perform the system call

iAdrQueue1:               .int Queue1
iAdrstItem:               .int stItem
iAdrszMessError:          .int szMessError
iAdrszMessEmpty:          .int szMessEmpty
iAdrszMessNotEmpty:       .int szMessNotEmpty
iAdrszMessResult:         .int szMessResult
iAdrszCarriageReturn:     .int szCarriageReturn
iAdrsMessIdent:           .int sMessIdent
iAdrsMessValue1:          .int sMessValue1
iAdrsMessValue2:          .int sMessValue2
/******************************************************************/
/*     test if queue empty                                        */
/******************************************************************/
/* r0 contains the address of queue structure */
isEmpty:
    push {r1,r2,lr}                         @ save  registres
    ldr r1,[r0,#queue_ptdeb]                @ begin pointer
    ldr r2,[r0,#queue_ptfin]                @ begin pointer
    cmp r1,r2
    moveq r0,#1                             @ empty queue
    movne r0,#0                             @ not empty
    pop {r1,r2,lr}                          @ restaur registers
    bx lr                                   @ return
/******************************************************************/
/*     add item  in queue                                         */
/******************************************************************/
/* r0 contains the address of queue structure */
/* r1 contains the address of item            */
pushQueue:
    push {r1-r4,lr}                         @ save  registres
    add r2,r0,#queue_stvalue                @ address of values structure
    ldr r3,[r0,#queue_ptfin]                @ end pointer
    add r2,r3                               @ free address of queue
    ldr r4,[r1,#value_ident]                @ load ident item
    str r4,[r2,#value_ident]                @ and store in queue
    ldr r4,[r1,#value_value1]               @ idem
    str r4,[r2,#value_value1]
    ldr r4,[r1,#value_value2]
    str r4,[r2,#value_value2]
    add r3,#value_fin
    cmp r3,#value_fin * NBMAXIELEMENTS
    moveq r0,#-1                            @ error
    beq 100f
    str r3,[r0,#queue_ptfin]                @ store new end pointer
100:
    pop {r1-r4,lr}                          @ restaur registers
    bx lr                                   @ return
/******************************************************************/
/*     pop queue                                                  */
/******************************************************************/
/* r0 contains the address of queue structure */
popQueue:
    push {r1,r2,lr}                         @ save  registres
    mov r1,r0                               @ control if empty queue
    bl isEmpty
    cmp r0,#1                               @ yes -> error
    moveq r0,#-1
    beq 100f
    mov r0,r1
    ldr r1,[r0,#queue_ptdeb]                @ begin pointer
    add r2,r0,#queue_stvalue                @ address of begin values item
    add r2,r1                               @ address of item
    add r1,#value_fin
    str r1,[r0,#queue_ptdeb]                @ store nex begin pointer
    mov r0,r2                               @ return pointer item
100:
    pop {r1,r2,lr}                          @ restaur registers
    bx lr                                   @ return
/******************************************************************/
/*     display text with size calculation                         */
/******************************************************************/
/* r0 contains the address of the message */
affichageMess:
    push {r0,r1,r2,r7,lr}                   @ save  registres
    mov r2,#0                               @ counter length
1:                                          @ loop length calculation
    ldrb r1,[r0,r2]                         @ read octet start position + index
    cmp r1,#0                               @ if 0 its over
    addne r2,r2,#1                          @ else add 1 in the length
    bne 1b                                  @ and loop
                                            @ so here r2 contains the length of the message
    mov r1,r0                               @ address message in r1
    mov r0,#STDOUT                          @ code to write to the standard output Linux
    mov r7, #WRITE                          @ code call system "write"
    svc #0                                  @ call systeme
    pop {r0,r1,r2,r7,lr}                    @ restaur registers */
    bx lr                                   @ return
/******************************************************************/
/*     Converting a register to a decimal                                 */
/******************************************************************/
/* r0 contains value and r1 address area   */
.equ LGZONECAL,   10
conversion10:
    push {r1-r4,lr}                         @ save registers
    mov r3,r1
    mov r2,#LGZONECAL
1:                                          @ start loop
    bl divisionpar10                        @ r0 <- dividende. quotient ->r0 reste -> r1
    add r1,#48                              @ digit
    strb r1,[r3,r2]                         @ store digit on area
    cmp r0,#0                               @ stop if quotient = 0
    subne r2,#1                               @ previous position
    bne 1b                                  @ else loop
                                            @ end replaces digit in front of area
    mov r4,#0
2:
    ldrb r1,[r3,r2]
    strb r1,[r3,r4]                         @ store in area begin
    add r4,#1
    add r2,#1                               @ previous position
    cmp r2,#LGZONECAL                       @ end
    ble 2b                                  @ loop
    mov r1,#' '
3:
    strb r1,[r3,r4]
    add r4,#1
    cmp r4,#LGZONECAL                       @ end
    ble 3b
100:
    pop {r1-r4,lr}                          @ restaur registres
    bx lr                                   @return
/***************************************************/
/*   division par 10   signé                       */
/* Thanks to http://thinkingeek.com/arm-assembler-raspberry-pi/*
/* and   http://www.hackersdelight.org/            */
/***************************************************/
/* r0 dividende   */
/* r0 quotient */
/* r1 remainder  */
divisionpar10:
  /* r0 contains the argument to be divided by 10 */
    push {r2-r4}                           @ save registers  */
    mov r4,r0
    mov r3,#0x6667                         @ r3 <- magic_number  lower
    movt r3,#0x6666                        @ r3 <- magic_number  upper
    smull r1, r2, r3, r0                   @ r1 <- Lower32Bits(r1*r0). r2 <- Upper32Bits(r1*r0)
    mov r2, r2, ASR #2                     @ r2 <- r2 >> 2
    mov r1, r0, LSR #31                    @ r1 <- r0 >> 31
    add r0, r2, r1                         @ r0 <- r2 + r1
    add r2,r0,r0, lsl #2                   @ r2 <- r0 * 5
    sub r1,r4,r2, lsl #1                   @ r1 <- r4 - (r2 * 2)  = r4 - (r0 * 10)
    pop {r2-r4}
    bx lr                                  @ return


 s:proc options(main)reorder;dcl sysprint file,m(7)init(
 ' s:proc options(main)reorder\dcl sysprint file,m(7)init(',
 ' *)char(99),i,j,(translate,substr)builtin,c char\i=1\j=n',
 ' \do i=1 to 6\put skip list('' '''''')\do j=2 to 56\c=substr',
 ' (m(i),j)\put edit(c)(a)\n:proc\put list(translate(m(i),',
 ' ''5e''x,''e0''x))\end n\if c='''''''' then put edit(c)(a)\end\ ',
 ' put edit('''''','')(a(50))\end\do i=2 to 6\j=n\end\end s\  ',
 *)char(99),i,j,(translate,substr)builtin,c char;i=1;j=n
 ;do i=1 to 6;put skip list(' ''');do j=2 to 56;c=substr
 (m(i),j);put edit(c)(a);n:proc;put list(translate(m(i),
 '5e'x,'e0'x));end n;if c='''' then put edit(c)(a);end;
 put edit(''',')(a(50));end;do i=2 to 6;j=n;end;end s;


This is TeX, Version 3.1415926 (no format preloaded)
(q.tex \output {\message {\output \the \output \end }\batchmode }\end


actor Main
new create(env: Env) =>
let a = """env.out.print("actor Main\nnew create(env: Env) =>\nlet a = \"\"\""+a+"\"\"\"\n"+a)"""
env.out.print("actor Main\nnew create(env: Env) =>\nlet a = \"\"\""+a+"\"\"\"\n"+a)