(*------------------------------------------------------------------*)

#define ATS_DYNLOADFLAG 0

#include "share/atspre_staload.hats"

staload UN = "prelude/SATS/unsafe.sats"

(*------------------------------------------------------------------*)

vtypedef queue_vt (vt : [email protected]+, n : int) =
  (* A list that forms the queue, and a pointer to its last node. *)
  @(list_vt (vt, n), ptr)

#define NIL list_vt_nil ()
#define :: list_vt_cons

fn {}
queue_vt_nil {vt : [email protected]}
            () :
    queue_vt (vt, 0) =
  @(NIL, the_null_ptr)

fn {}
queue_vt_is_empty
          {n  : int}
          {vt : [email protected]}
          (q  : !queue_vt (vt, n)) :
    [is_empty : bool | is_empty == (n == 0)]
    bool is_empty =
  case+ q.0 of
  | NIL => true
  | _ :: _ => false

fn {vt : [email protected]}
queue_vt_enqueue
          {n : int}
          (q : queue_vt (vt, n),
           x : vt) :
    (* Returns the new queue. *)
    [m : int | 1 <= m; m == n + 1]
    queue_vt (vt, m) =
  let
    val @(lst, tail_ptr) = q
    prval _ = lemma_list_vt_param lst
  in
    case+ lst of
    | ~ NIL =>
      let
        val lst = x :: NIL
        val tail_ptr = $UN.castvwtp1{ptr} lst
      in
        @(lst, tail_ptr)
      end
    | _ :: _ =>
      let
        val old_tail = $UN.castvwtp0{list_vt (vt, 1)} tail_ptr
        val+ @ (hd :: tl) = old_tail

        (* Extend the list by one node, at its tail end. *)
        val new_tail : list_vt (vt, 1) = x :: NIL
        val tail_ptr = $UN.castvwtp1{ptr} new_tail
        prval _ = $UN.castvwtp0{void} tl
        val _ = tl := new_tail

        prval _ = [email protected] old_tail
        prval _ = $UN.castvwtp0{void} old_tail

        (* Let us cheat and simply *assert* (rather than prove) that
           the list has grown by one node. *)
        val lst = $UN.castvwtp0{list_vt (vt, n + 1)} lst
      in
        @(lst, tail_ptr)
      end
  end

(* The dequeue routine simply CANNOT BE CALLED with an empty queue.
   It requires a queue of type queue_vt (vt, n) where n is positive. *)
fn {vt : [email protected]}
queue_vt_dequeue
          {n : int | 1 <= n}
          (q : queue_vt (vt, n)) :
    (* Returns a tuple: the dequeued element and the new queue. *)
    [m : int | 0 <= m; m == n - 1]
    @(vt, queue_vt (vt, m)) =
  case+ q.0 of
  | ~ (x :: lst) => @(x, @(lst, q.1))

(* queue_vt is a linear type that must be freed. *)
extern fun {vt : [email protected]}
queue_vt$element_free : vt -> void
fn {vt : [email protected]}
queue_vt_free {n : int}
              (q : queue_vt (vt, n)) :
    void =
  let
    fun
    loop {n : nat} .<n>. (lst : list_vt (vt, n)) : void =
      case+ lst of
      | ~ NIL => begin end
      | ~ (hd :: tl) =>
        begin
          queue_vt$element_free<vt> hd;
          loop tl
        end
    prval _ = lemma_list_vt_param (q.0)
  in
    loop (q.0)
  end

(*------------------------------------------------------------------*)
(* An example: a queue of nonlinear strings. *)

vtypedef strq_vt (n : int) = queue_vt (string, n)

fn {}                  (* A parameterless template, for efficiency. *)
strq_vt_nil () : strq_vt 0 =
  queue_vt_nil ()

fn {}                  (* A parameterless template, for efficiency. *)
strq_vt_is_empty {n : int} (q : !strq_vt n) :
    [is_empty : bool | is_empty == (n == 0)] bool is_empty =
  queue_vt_is_empty<> q

fn
strq_vt_enqueue {n : int} (q : strq_vt n, x : string) :
    [m : int | 1 <= m; m == n + 1] strq_vt m =
  queue_vt_enqueue<string> (q, x)

fn (* Impossible to...     VVVVVV   ...call with an empty queue. *)
strq_vt_dequeue {n : int | 1 <= n} (q : strq_vt n) :
    [m : int | 0 <= m; m == n - 1] @(string, strq_vt m) =
  queue_vt_dequeue<string> q

fn
strq_vt_free {n : int} (q : strq_vt n) : void =
  let
    implement
    queue_vt$element_free<string> x =
      (* A nonlinear string will be allowed to leak. (It might be
         collected as garbage, however.) *)
      begin end
  in
    queue_vt_free<string> q
  end

macdef qnil = strq_vt_nil ()
overload iseqz with strq_vt_is_empty
overload << with strq_vt_enqueue
overload pop with strq_vt_dequeue
overload free with strq_vt_free

implement
main0 () =
  {
    val q = qnil
    val _ = println! ("val q = qnil")
    val _ = println! ("iseqz q = ", iseqz q)
    val _ = println! ("val q = q << \"one\" << \"two\" << \"three\"")
    val q = q << "one" << "two" << "three"
    val _ = println! ("iseqz q = ", iseqz q)
    val _ = println! ("val (x, q) = pop q")
    val (x, q) = pop q
    val _ = println! ("x = ", x)
    val _ = println! ("val (x, q) = pop q")
    val (x, q) = pop q
    val _ = println! ("x = ", x)
    val _ = println! ("val q = q << \"four\"")
    val q = q << "four"
    val _ = println! ("val (x, q) = pop q")
    val (x, q) = pop q
    val _ = println! ("x = ", x)
    val _ = println! ("val (x, q) = pop q")
    val (x, q) = pop q
    val _ = println! ("x = ", x)
    val _ = println! ("iseqz q = ", iseqz q)
    //val (x, q) = pop q  // If you uncomment this you cannot compile!
    val _ = free q
  }

(*------------------------------------------------------------------*)


push("qu", 2), push("qu", 44), push("qu", "xyz") ; TEST

MsgBox % "Len = " len("qu") ; Number of entries
While !empty("qu")          ; Repeat until queue is not empty
    MsgBox % pop("qu")      ; Print popped values (2, 44, xyz)
MsgBox Error = %ErrorLevel% ; ErrorLevel =  0: OK
MsgBox % pop("qu")          ; Empty
MsgBox Error = %ErrorLevel% ; ErrorLevel = -1: popped too much
MsgBox % "Len = " len("qu") ; Number of entries

push(queue,_) {             ; push _ onto queue named "queue" (!=_), _ string not containing |
    Global
    %queue% .= %queue% = "" ? _ : "|" _
}

pop(queue) {                ; pop value from queue named "queue" (!=_,_1,_2)
    Global
    RegExMatch(%queue%, "([^\|]*)\|?(.*)", _)
    Return _1, ErrorLevel := -(%queue%=""), %queue% := _2
}

empty(queue) {              ; check if queue named "queue" is empty
    Global
    Return %queue% = ""
}

len(queue) {                ; number of entries in "queue"
    Global
    StringReplace %queue%, %queue%, |, |, UseErrorLevel
    Return %queue% = "" ? 0 : ErrorLevel+1
}


FUNCTION PBMAIN () AS LONG
    REDIM s(1 TO DATACOUNT) AS STRING
    o$ = READ$(1)
    d$ = READ$(2)
    FOR n& = 1 TO DATACOUNT
        s(n&) = READ$(n&)
    NEXT
    OPEN o$ FOR OUTPUT AS 1
    FOR n& = 3 TO DATACOUNT - 1
        PRINT #1, s(n&)
    NEXT
    PRINT #1,
    FOR n& = 1 TO DATACOUNT
        PRINT #1, d$ & $DQ & s(n&) & $DQ
    NEXT
    PRINT #1, s(DATACOUNT)
    CLOSE

    DATA "output.src"
    DATA "    DATA "
    DATA "FUNCTION PBMAIN () AS LONG"
    DATA "    REDIM s(1 TO DATACOUNT) AS STRING"
    DATA "    o$ = READ$(1)"
    DATA "    d$ = READ$(2)"
    DATA "    FOR n& = 1 TO DATACOUNT"
    DATA "        s(n&) = READ$(n&)"
    DATA "    NEXT"
    DATA "    OPEN o$ FOR OUTPUT AS 1"
    DATA "    FOR n& = 3 TO DATACOUNT - 1"
    DATA "        PRINT #1, s(n&)"
    DATA "    NEXT"
    DATA "    PRINT #1,"
    DATA "    FOR n& = 1 TO DATACOUNT"
    DATA "        PRINT #1, d$ & $DQ & s(n&) & $DQ"
    DATA "    NEXT"
    DATA "    PRINT #1, s(DATACOUNT)"
    DATA "    CLOSE"
    DATA "END FUNCTION"
END FUNCTION


$S = '$S = $S.Substring(0,5) + [string][char]39 + $S + [string][char]39 + [string][char]10 + $S.Substring(5)'
$S.Substring(0,5) + [string][char]39 + $S + [string][char]39 + [string][char]10 + $S.Substring(5)


#!/usr/bin/awk -f

BEGIN {
    delete q
    print "empty? " emptyP()
    print "push " push("a")
    print "push " push("b")
    print "empty? " emptyP()
    print "pop " pop()
    print "pop " pop()
    print "empty? " emptyP()
    print "pop " pop()
}

function push(n) {
    q[length(q)+1] = n
    return n
}

function pop() {
    if (emptyP()) {
        print "Popping from empty queue."
        exit
    }
    r = q[length(q)]
    delete q[length(q)]
    return r
}

function emptyP() {
    return length(q) == 0
}


@echo off
setlocal enableDelayedExpansion

:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
:: FIFO queue usage

:: Define the queue
call :newQueue myQ

:: Populate the queue
for %%A in (value1 value2 value3) do call :enqueue myQ %%A

:: Test if queue is empty by examining the tail "attribute"
if myQ.tail==0 (echo myQ is empty) else (echo myQ is NOT empty)

:: Peek at the head of the queue
call:peekQueue myQ val && echo a peek at the head of myQueue shows !val!

:: Process the first queue value
call :dequeue myQ val && echo dequeued myQ value=!val!

:: Add some more values to the queue
for %%A in (value4 value5 value6) do call :enqueue myQ %%A

:: Process the remainder of the queue
:processQueue
call :dequeue myQ val || goto :queueEmpty
echo dequeued myQ value=!val!
goto :processQueue
:queueEmpty

:: Test if queue is empty using the empty "method"/"macro". Use of the
:: second IF statement serves to demonstrate the negation of the empty
:: "method". A single IF could have been used with an ELSE clause instead.
if %myQ.empty% echo myQ is empty
if not %myQ.empty% echo myQ is NOT empty
exit /b

:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
:: FIFO queue definition

:newQueue qName
set /a %~1.head=1, %~1.tail=0
:: Define an empty "method" for this queue as a sort of macro
set "%~1.empty=^!%~1.tail^! == 0"
exit /b

:enqueue qName value
set /a %~1.tail+=1
set %~1.!%~1.tail!=%2
exit /b

:dequeue qName returnVar
:: Sets errorlevel to 0 if success
:: Sets errorlevel to 1 if failure because queue was empty
if !%~1.tail! equ 0 exit /b 1
for %%N in (!%~1.head!) do (
  set %~2=!%~1.%%N!
  set %~1.%%N=
)
if !%~1.head! == !%~1.tail! (set /a "%~1.head=1, %~1.tail=0") else set /a %~1.head+=1
exit /b 0

:peekQueue qName returnVar
:: Sets errorlevel to 0 if success
:: Sets errorlevel to 1 if failure because queue was empty
if !%~1.tail! equ 0 exit /b 1
for %%N in (!%~1.head!) do set %~2=!%~1.%%N!
exit /b 0


      FIFOSIZE = 1000

      FOR n = 3 TO 5
        PRINT "Push ";n : PROCenqueue(n)
      NEXT
      PRINT "Pop " ; FNdequeue
      PRINT "Push 6" : PROCenqueue(6)
      REPEAT
        PRINT "Pop " ; FNdequeue
      UNTIL FNisempty
      PRINT "Pop " ; FNdequeue
      END

      DEF PROCenqueue(n) : LOCAL f%
      DEF FNdequeue : LOCAL f% : f% = 1
      DEF FNisempty : LOCAL f% : f% = 2
      PRIVATE fifo(), rptr%, wptr%
      DIM fifo(FIFOSIZE-1)
      CASE f% OF
        WHEN 0:
          wptr% = (wptr% + 1) MOD FIFOSIZE
          IF rptr% = wptr% ERROR 100, "Error: queue overflowed"
          fifo(wptr%) = n
        WHEN 1:
          IF rptr% = wptr% ERROR 101, "Error: queue empty"
          rptr% = (rptr% + 1) MOD FIFOSIZE
          = fifo(rptr%)
        WHEN 2:
          = (rptr% = wptr%)
      ENDCASE
      ENDPROC


queue ← {
  data ← ⟨⟩
  Push ⇐ {data∾˜↩𝕩}
  Pop ⇐ {
    𝕊𝕩:
    0=≠data ? •Show "Cannot pop from empty queue";
    (data↓˜↩¯1)⊢⊑⌽data
  }
  Empty ⇐ {𝕊𝕩: 0=≠data}
  Display ⇐ {𝕊𝕩: •Show data}
}

q1 ← queue

•Show [email protected]
q1.Push 3
q1.Push 4
[email protected]
•Show [email protected]
[email protected]


  ( queue
  =   (list=)
      (enqueue=.(.!arg) !(its.list):?(its.list))
      ( dequeue
      =   x
        .   !(its.list):?(its.list) (.?x)
          & !x
      )
      (empty=.!(its.list):)
  )


#include <stdio.h>
#include <stdlib.h>
#include <string.h>

typedef int DATA; /* type of data to store in queue */
typedef struct {
    DATA *buf;
    size_t head, tail, alloc;
} queue_t, *queue;

queue q_new()
{
    queue q = malloc(sizeof(queue_t));
    q->buf = malloc(sizeof(DATA) * (q->alloc = 4));
    q->head = q->tail = 0;
    return q;
}

int empty(queue q)
{
    return q->tail == q->head;
}

void enqueue(queue q, DATA n)
{
    if (q->tail >= q->alloc) q->tail = 0;
    q->buf[q->tail++] = n;

    // Fixed bug where it failed to resizes
    if (q->tail == q->alloc) {  /* needs more room */
        q->buf = realloc(q->buf, sizeof(DATA) * q->alloc * 2);
        if (q->head) {
            memcpy(q->buf + q->head + q->alloc, q->buf + q->head,
                sizeof(DATA) * (q->alloc - q->head));
            q->head += q->alloc;
        } else
            q->tail = q->alloc;
        q->alloc *= 2;
    }
}

int dequeue(queue q, DATA *n)
{
    if (q->head == q->tail) return 0;
    *n = q->buf[q->head++];
    if (q->head >= q->alloc) { /* reduce allocated storage no longer needed */
        q->head = 0;
        if (q->alloc >= 512 && q->tail < q->alloc / 2)
            q->buf = realloc(q->buf, sizeof(DATA) * (q->alloc/=2));
    }
    return 1;
}


[ ' [ ' unbuild dup 4 split rot space rot 3 times join echo$ ] unbuild dup 4 split rot space rot 3 times join echo$ ]


public class FIFO<T>
{
  class Node
  {
    public T Item { get; set; }
    public Node Next { get; set; }
  }
  Node first = null;
  Node last = null;
  public void push(T item)
  {
    if (empty())
    {
      //Uses object initializers to set fields of new node
      first = new Node() { Item = item, Next = null };
      last = first;
    }
    else
    {
      last.Next = new Node() { Item = item, Next = null };
      last = last.Next;
    }
  }
  public T pop()
  {
    if (first == null)
      throw new System.Exception("No elements");
    if (last == first)
      last = null;
    T temp = first.Item;
    first = first.Next;
    return temp;
  }
  public bool empty()
  {
    return first == null;
  }
}


rebol [] q: [print ["rebol [] q:" mold q "do q"]] do q


namespace rosettacode
{
  template<typename T> class queue
  {
  public:
    queue();
    ~queue();
    void push(T const& t);
    T pop();
    bool empty();
  private:
    void drop();
    struct node;
    node* head;
    node* tail;
  };

  template<typename T> struct queue<T>::node
  {
    T data;
    node* next;
    node(T const& t): data(t), next(0) {}
  };

  template<typename T>
   queue<T>::queue():
    head(0)
  {
  }

  template<typename T>
   inline void queue<T>::drop()
  {
    node* n = head;
    head = head->next;
    delete n;
  }

  template<typename T>
   queue<T>::~queue()
  {
    while (!empty())
      drop();
  }

  template<typename T>
   void queue<T>::push(T const& t)
  {
    node*& next = head? tail->next : head;
    next = new node(t);
    tail = next;
  }

  template<typename T>
   T queue<T>::pop()
  {
    T tmp = head->data;
    drop();
    return tmp;
  }

  template<typename T>
   bool queue<T>::empty()
  {
    return head == 0;
  }
}


/*REXX program outputs its own 1─line source.*/    say sourceline(1)


user=> (def empty-queue clojure.lang.PersistentQueue/EMPTY)
#'user/empty-queue
user=> (def aqueue (atom empty-queue))
#'user/aqueue
; Check if queue is empty
user=> (empty? @aqueue)
true
; As with other Clojure data structures, you can add items using conj and into
user=> (swap! aqueue conj 1)
user=> (swap! aqueue into [2 3 4])
user=> (pprint @aqueue)
<-(1 2 3 4)-<
; You can read the head of the queue with peek
user=> (peek @aqueue)
1
; You can remove the head producing a new queue using pop
user=> (pprint (pop @aqueue))
<-(2 3 4)-<
; pop returns a new queue, the original is still intact
user=> (pprint @aqueue)
<-(1 2 3 4)-<
; you can treat a queue as a sequence
user=> (into [] @aqueue)
[1 2 3 4]
; but remember that using rest or next converts the queue to a seq. Compare:
user=> (-> @aqueue rest (conj 5) pprint)
(5 2 3 4)
; with:
user=> (-> @aqueue pop (conj 5) pprint)
<-(2 3 4 5)-<


# Implement a fifo as an array of arrays, to
# greatly amortize dequeue costs, at some expense of
# memory overhead and insertion time.  The speedup
# depends on the underlying JS implementation, but
# it's significant on node.js.
Fifo = ->
  max_chunk = 512
  arr = [] # array of arrays
  count = 0

  self =
    enqueue: (elem) ->
      if count == 0 or arr[arr.length-1].length >= max_chunk
        arr.push []
      count += 1
      arr[arr.length-1].push elem
    dequeue: (elem) ->
      throw Error("queue is empty") if count == 0
      val = arr[0].shift()
      count -= 1
      if arr[0].length == 0
        arr.shift()
      val
    is_empty: (elem) ->
      count == 0

# test
do ->
  max = 5000000
  q = Fifo()
  for i in [1..max]
    q.enqueue
      number: i

  console.log q.dequeue()
  while !q.is_empty()
    v = q.dequeue()
  console.log v


val q = "\"" * 3
val c = """val q = "\"" * 3
val c = %s%s%s
println(c format (q, c, q))
"""
println(c format (q, c, q))


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


(defstruct (queue (:constructor %make-queue))
  (items '() :type list)
  (tail '() :type list))

(defun make-queue ()
  "Returns an empty queue."
  (%make-queue))

(defun queue-empty-p (queue)
  "Returns true if the queue is empty."
  (endp (queue-items queue)))

(defun enqueue (item queue)
  "Enqueue item in queue. Returns the queue."
  (prog1 queue
    (if (queue-empty-p queue)
      (setf (queue-items queue) (list item)
            (queue-tail queue) (queue-items queue))
      (setf (cdr (queue-tail queue)) (list item)
            (queue-tail queue) (cdr (queue-tail queue))))))

(defun dequeue (queue)
  "Dequeues an item from queue. Signals an error if queue is empty."
  (if (queue-empty-p queue)
    (error "Cannot dequeue from empty queue.")
    (pop (queue-items queue))))


MODULE Queue;
IMPORT
	Boxes;
TYPE
	Instance* = POINTER TO LIMITED RECORD
		size: LONGINT;
		first,last: LONGINT;
		_queue: POINTER TO ARRAY OF Boxes.Box;
	END;

	PROCEDURE (self: Instance) Initialize(capacity: LONGINT),NEW;
	BEGIN
		self.size := 0;
		self.first := 0;
		self.last := 0;
		NEW(self._queue,capacity)
	END Initialize;

	PROCEDURE New*(capacity: LONGINT): Instance;
	VAR
		aQueue: Instance;
	BEGIN
		NEW(aQueue);aQueue.Initialize(capacity);RETURN aQueue
	END New;

	PROCEDURE (self: Instance) IsEmpty*(): BOOLEAN, NEW;
	BEGIN
		RETURN self.size = 0;
	END IsEmpty;

	PROCEDURE (self: Instance) Capacity*(): LONGINT, NEW;
	BEGIN
		RETURN LEN(self._queue)
	END Capacity;

	PROCEDURE (self: Instance) Size*(): LONGINT, NEW;
	BEGIN
		RETURN self.size
	END Size;

	PROCEDURE (self: Instance) IsFull*(): BOOLEAN, NEW;
	BEGIN
		RETURN self.size = self.Capacity()
	END IsFull;

	PROCEDURE (self: Instance) Push*(b: Boxes.Box), NEW;
	VAR
		i, j, newCapacity, oldSize: LONGINT;
		queue: POINTER TO ARRAY OF Boxes.Box;
	BEGIN
		INC(self.size);
		self._queue[self.last] := b;
		self.last := (self.last + 1) MOD self.Capacity();
		IF self.IsFull() THEN
			(* grow queue *)
			newCapacity := self.Capacity() + (self.Capacity() DIV 2);
			(* new queue *)
			NEW(queue,newCapacity);
			(* move data from old to new queue *)
			i := self.first; j := 0; oldSize := self.Capacity() - self.first + self.last;
			WHILE (j < oldSize) & (j < newCapacity - 1) DO
				queue[j] := self._queue[i];
				i := (i + 1) MOD newCapacity;INC(j)
			END;
			self._queue := queue;self.first := 0;self.last := j
		END
	END Push;

	PROCEDURE (self: Instance) Pop*(): Boxes.Box, NEW;
	VAR
		b: Boxes.Box;
	BEGIN
		ASSERT(~self.IsEmpty());
		DEC(self.size);
		b := self._queue[self.first];
		self._queue[self.first] := NIL;
		self.first := (self.first + 1) MOD self.Capacity();
		RETURN b
	END Pop;

END Queue.


$ include "seed7_05.s7i";
const array string: prog is [](
"$ include \"seed7_05.s7i\";",
"const array string: prog is [](",
"const proc: main is func",
"  local var integer: number is 0;",
"  begin",
"    for number range 1 to 2 do writeln(prog[number]); end for;",
"    for number range 1 to 11 do",
"      writeln(literal(prog[number]) <& \",\");",
"    end for;",
"    writeln(literal(prog[12]) <& \");\");",
"    for number range 3 to 12 do writeln(prog[number]); end for;",
"  end func;");
const proc: main is func
  local var integer: number is 0;
  begin
    for number range 1 to 2 do writeln(prog[number]); end for;
    for number range 1 to 11 do
      writeln(literal(prog[number]) <& ",");
    end for;
    writeln(literal(prog[12]) <& ");");
    for number range 3 to 12 do writeln(prog[number]); end for;
  end func;


i var i "i var i %c%s%c = 34 i 34 i printf" = 34 i 34 i printf


include "strings.coh";
include "malloc.coh";

# Define types. The calling code is expected to provide a QueueData type.
record QueueItem is
    data: QueueData;
    next: [QueueItem];
end record;

record QueueMeta is
    head: [QueueItem];
    tail: [QueueItem];
end record;

typedef Queue is [QueueMeta];
const Q_NONE := 0 as [QueueItem];

# Allocate and free the queue datastructure.
sub MakeQueue(): (q: Queue) is
    q := Alloc(@bytesof QueueMeta) as Queue;
    q.head := Q_NONE;
    q.tail := Q_NONE;
end sub;

sub FreeQueue(q: Queue) is
    var cur := q.head;
    while cur != Q_NONE loop
        var next := cur.next;
        Free(cur as [uint8]);
        cur := next;
    end loop;
    Free(q as [uint8]);
end sub;

# Check if queue is empty.
sub QueueEmpty(q: Queue): (r: uint8) is
    r := 0;
    if q.head == Q_NONE then
        r := 1;
    end if;
end sub;

# Enqueue and dequeue data. Cowgol has no exceptions, so the calling code
# should check QueueEmpty first.
sub Enqueue(q: Queue, d: QueueData) is
    var item := Alloc(@bytesof QueueItem) as [QueueItem];
    item.data := d;
    item.next := Q_NONE;
    if q.head == Q_NONE then
        q.head := item;
    else
        q.tail.next := item;
    end if;
    q.tail := item;
end sub;

sub Dequeue(q: Queue): (d: QueueData) is
    d := q.head.data;
    var cur := q.head;
    q.head := q.head.next;
    Free(cur as [uint8]);
    if q.head == Q_NONE then
        q.tail := Q_NONE;
    end if;
end sub;


queue:
	{ :start 0 :end 0 }

enqueue q item:
	set-to q q!end item
	set-to q :end ++ q!end

dequeue q:
	if empty q:
		Raise :value-error "popping from empty queue"
	q! q!start
	delete-from q q!start
	set-to q :start ++ q!start

empty q:
	= q!start q!end


[:s| Transcript show: s, s printString; cr ] value: '[:s| Transcript show: s, s printString; cr ] value: '


        S = ' OUTPUT = " S = 0" S "0"; OUTPUT = REPLACE(S,+"","0");END'
        OUTPUT = " S = '" S ""; OUTPUT = REPLACE(S,+"","'");END


program QueueDefinition;

{$APPTYPE CONSOLE}

uses
  System.Generics.Collections;

type
  TQueue = System.Generics.Collections.TQueue<Integer>;

  TQueueHelper = class helper for TQueue
    function Empty: Boolean;
    function Pop: Integer;
    procedure Push(const NewItem: Integer);
  end;

{ TQueueHelper }

function TQueueHelper.Empty: Boolean;
begin
  Result := count = 0;
end;

function TQueueHelper.Pop: Integer;
begin
  Result := Dequeue;
end;

procedure TQueueHelper.Push(const NewItem: Integer);
begin
  Enqueue(NewItem);
end;

var
  Queue: TQueue;
  i: Integer;

begin
  Queue := TQueue.Create;

  for i := 1 to 1000 do
    Queue.push(i);

  while not Queue.Empty do
    Write(Queue.pop, ' ');
  Writeln;

  Queue.Free;
  Readln;
end.


def makeQueue() {
  def [var head, var tail] := Ref.promise()

  def writer {
    to enqueue(value) {
      def [nh, nt] := Ref.promise()
      tail.resolve([value, nh])
      tail := nt
    }
  }

  def reader {
    to empty() { return !Ref.isResolved(head) }

    to dequeue(whenEmpty) {
      if (Ref.isResolved(head)) {
        def [value, next] := head
        head := next
        return value
      } else {
        throw.eject(whenEmpty, "pop() of empty queue")
      }
    }
  }

  return [reader, writer]
}


;; put info string in permanent storage for later use
(info 'make-Q
"usage: (define q (make-Q)) ;  (q '[top | empty? | pop | push value | to-list | from-list list])")

;; make-Q
(define (make-Q)
  (let ((q (make-vector 0)))
    (lambda (message . args)
      (case message
        ((empty?) (vector-empty? q))
        ((top) (if (vector-empty? q) (error  'Q:top:empty q) (vector-ref q 0)))
        ((push) (vector-push q (car args)))
        ((pop) (if (vector-empty? q) (error 'Q:pop:empty q) (vector-shift q)))
        ((to-list) (vector->list q))
        ((from-list) (set! q (list->vector (car args))) q )
        (else (info 'make-Q) (error  "Q:bad message:" message )))))) ; display info if unknown message

;;
(define q (make-Q))
(q 'empty?) → #t
(q 'push 'first) → first
(q 'push 'second) → second
(q 'pop) → first
(q 'pop) → second
(q 'top)
"💬 error: Q:top:empty #()"
(q 'from-list '( 6 7 8)) → #( 6 7 8)
(q 'top) → 6
(q 'pop) → 6
(q 'to-list)→ (7 8)
(q 'delete)
"💭 error: Q:bad message: delete"

;; save make-Q
(local-put 'make-Q)


join { {} A B  } any_string
=> any_stringAany_stringB


program quine;

const
     apos: Char = Chr(39);
     comma: Char = Chr(44);
     lines: Array[1..17] of String[80] = (
'program quine;',
'',
'const',
'     apos: Char = Chr(39);',
'     comma: Char = Chr(44);',
'     lines: Array[1..17] of String[80] = (',
'     );',
'',
'var',
'   num: Integer;',
'',
'begin',
'     for num := 1 to 6 do writeln(lines[num]);',
'     for num := 1 to 16 do writeln(apos, lines[num], apos, comma);',
'%     writeln(apos, lines[17], apos);',
'     for num := 7 to 17 do writeln(lines[num]);',
'end.'
     );

var
   num: Integer;

begin
     for num := 1 to 6 do writeln(lines[num]);
     for num := 1 to 16 do writeln(apos, lines[num], apos, comma);
     writeln(apos, lines[17], apos);
     for num := 7 to 17 do writeln(lines[num]);
end.


import extensions;

template queue<T>
{
    T[]  theArray;
    int  theTop;
    int  theTale;

    constructor()
    {
        theArray := new T[](8);
        theTop := 0;
        theTale := 0;
    }

    bool empty()
        = theTop == theTale;

    push(T object)
    {
        if (theTale > theArray.Length)
        {
            theArray := theArray.reallocate(theTale)
        };

        theArray[theTale] := object;

        theTale += 1
    }

    T pop()
    {
        if (theTale == theTop)
            { InvalidOperationException.new:"Queue is empty".raise() };

        T item := theArray[theTop];

        theTop += 1;

        ^ item
    }
}

public program()
{
    queue<int> q := new queue<int>();
    q.push(1);
    q.push(2);
    q.push(3);
    console.printLine(q.pop());
    console.printLine(q.pop());
    console.printLine(q.pop());
    console.printLine("a queue is ", q.empty().iif("empty","not empty"));
    console.print("Trying to pop:");
    try
    {
        q.pop()
    }
    catch(Exception e)
    {
        console.printLine(e.Message)
    }
}


component GenericQueue ( Queue, Element );
 type Queue;
      Queue (MaxLength = integer) -> Queue;
      Length( Queue )           -> integer;
      Empty ( Queue )           -> boolean;
      Full ( Queue )            -> boolean;
      Push ( Queue, Element)    -> nothing;
      Pull ( Queue )            -> Element;
begin
      Queue (MaxLength) = Queue:[ MaxLength; length:=0; list=alist(Element) ];
      Length ( queue ) = queue.length;
      Empty ( queue ) = (queue.length <= 0);
      Full ( queue ) = (queue.length >= queue.MaxLength);

      Push ( queue, element ) =
                   [ exception (Full(queue), "Queue Overflow");
                     queue.length:= queue.length + 1;
                     add (queue.list, element)];
      Pull ( queue ) =
                   [ exception (Empty(queue), "Queue Underflow");
                     queue.length:= queue.length - 1;
                     remove(first(queue.list))];
end component GenericQueue;


@(deffilter me ("ME" "@(bind me "ME")
@(output)
@@(deffilter me ("ME" "@{me :filter me}"))
@{me :filter (me :from_html)}
@(end)"))
@(bind me "ME")
@(output)
@@(deffilter me ("ME" "@{me :filter me}"))
@{me :filter (me :from_html)}
@(end)


defmodule Queue do
  def new, do: {Queue, [], []}

  def push({Queue, input, output}, x), do: {Queue, [x|input], output}

  def pop({Queue, [], []}), do: (raise RuntimeError, message: "empty Queue")
  def pop({Queue, input, []}), do: pop({Queue, [], Enum.reverse(input)})
  def pop({Queue, input, [h|t]}), do: {h, {Queue, input, t}}

  def empty?({Queue, [], []}), do: true
  def empty?({Queue, _, _}), do: false
end


-module(fifo).
-export([new/0, push/2, pop/1, empty/1]).

new() -> {fifo, [], []}.

push({fifo, In, Out}, X) -> {fifo, [X|In], Out}.

pop({fifo, [], []}) -> erlang:error('empty fifo');
pop({fifo, In, []}) -> pop({fifo, [], lists:reverse(In)});
pop({fifo, In, [H|T]}) -> {H, {fifo, In, T}}.

empty({fifo, [], []}) -> true;
empty({fifo, _, _}) -> false.


Public Sub quine()
    quote = Chr(34)
    comma = Chr(44)
    cont = Chr(32) & Chr(95)
    n = Array( _
"Public Sub quine()", _
"    quote = Chr(34)", _
"    comma = Chr(44)", _
"    cont = Chr(32) & Chr(95)", _
"    n = Array( _", _
"    For i = 0 To 4", _
"        Debug.Print n(i)", _
"    Next i", _
"    For i = 0 To 15", _
"        Debug.Print quote & n(i) & quote & comma & cont", _
"    Next i", _
"    Debug.Print quote & n(15) & quote & Chr(41)", _
"    For i = 5 To 15", _
"        Debug.Print n(i)", _
"    Next i", _
"End Sub")
    For i = 0 To 4
        Debug.Print n(i)
    Next i
    For i = 0 To 14
        Debug.Print quote & n(i) & quote & comma & cont
    Next i
    Debug.Print quote & n(15) & quote & Chr(41)
    For i = 5 To 15
        Debug.Print n(i)
    Next i
End Sub


@VAR s = «@SAY (@FORMAT fmt:"@VAR s = %c%s%c;" 0x00AB s 0x00BB) s no_nl:;»; @SAY (@FORMAT fmt:"@VAR s = %c%s%c;" 0x00AB s 0x00BB) s no_nl:;


PROGRAM CLASS_DEMO

CLASS QUEUE

   LOCAL SP
   LOCAL DIM STACK[100]

   FUNCTION ISEMPTY()
      ISEMPTY=(SP=0)
   END FUNCTION

   PROCEDURE INIT
      SP=0
   END PROCEDURE

   PROCEDURE POP(->XX)
      XX=STACK[SP]
      SP=SP-1
   END PROCEDURE

   PROCEDURE PUSH(XX)
      SP=SP+1
      STACK[SP]=XX
   END PROCEDURE

END CLASS

NEW PILA:QUEUE

BEGIN
    PILA_INIT  ! constructor
    FOR N=1 TO 4 DO  ! push 4 numbers
       PRINT("Push";N)
       PILA_PUSH(N)
    END FOR
    FOR I=1 TO 5 DO  ! pop 5 numbers
       IF NOT PILA_ISEMPTY() THEN
           PILA_POP(->N)
           PRINT("Pop";N)
         ELSE
           PRINT("Queue is empty!")
       END IF
    END FOR
    PRINT("* End *")
END PROGRAM


USING: accessors kernel ;
IN: rosetta-code.queue-definition

TUPLE: queue head tail ;
TUPLE: node value next ;

: <queue> ( -- queue ) queue new ;
: <node> ( obj -- node ) node new swap >>value ;

: empty? ( queue -- ? ) head>> >boolean not ;

: enqueue ( obj queue -- )
    [ <node> ] dip 2dup dup empty?
    [ head<< ] [ tail>> next<< ] if tail<< ;

: dequeue ( queue -- obj )
    dup empty? [ "Cannot dequeue empty queue." throw ] when
    [ head>> value>> ] [ head>> next>> ] [ head<< ] tri ;


class Queue
{
  List queue := [,]

  public Void push (Obj obj)
  {
    queue.add (obj)  // add to right of list
  }

  public Obj pop ()
  {
    if (queue.isEmpty)
      throw (Err("queue is empty"))
    else
    {
      return queue.removeAt(0) // removes left-most item
    }
  }

  public Bool isEmpty ()
  {
    queue.isEmpty
  }
}


LIBRARY ieee; USE std.TEXTIO.all;
entity quine is end entity quine;
architecture beh of quine is
  type str_array is array(1 to 20) of string(1 to 80);
  constant src : str_array := (
    "LIBRARY ieee; USE std.TEXTIO.all;                                               ",
    "entity quine is end entity quine;                                               ",
    "architecture beh of quine is                                                    ",
    "  type str_array is array(1 to 20) of string(1 to 80);                          ",
    "  constant src : str_array := (                                                 ",
    "begin                                                                           ",
    "  process variable l : line; begin                                              ",
    "    for i in 1 to 5 loop write(l, src(i)); writeline(OUTPUT, l); end loop;      ",
    "    for i in 1 to 20 loop                                                       ",
    "      write(l, character'val(32)&character'val(32));                            ",
    "      write(l, character'val(32)&character'val(32));                            ",
    "      write(l, character'val(34)); write(l, src(i)); write(l,character'val(34));",
    "      if i /= 20 then write(l, character'val(44));                              ",
    "      else            write(l, character'val(41)&character'val(59)); end if;    ",
    "      writeline(OUTPUT, l);                                                     ",
    "    end loop;                                                                   ",
    "    for i in 6 to 20 loop write(l, src(i)); writeline(OUTPUT, l); end loop;     ",
    "    wait;                                                                       ",
    "  end process;                                                                  ",
    "end architecture beh;                                                           ");
begin
  process variable l : line; begin
    for i in 1 to 5 loop write(l, src(i)); writeline(OUTPUT, l); end loop;
    for i in 1 to 20 loop
      write(l, character'val(32)&character'val(32));
      write(l, character'val(32)&character'val(32));
      write(l, character'val(34)); write(l, src(i)); write(l,character'val(34));
      if i /= 20 then write(l, character'val(44));
      else            write(l, character'val(41)&character'val(59)); end if;
      writeline(OUTPUT, l);
    end loop;
    for i in 6 to 20 loop write(l, src(i)); writeline(OUTPUT, l); end loop;
    wait;
  end process;
end architecture beh;


1024 constant size
create buffer size cells allot
here constant end
variable head  buffer head !
variable tail  buffer tail !
variable used       0 used !

: empty?  used @ 0= ;
: full?   used @ size = ;

: next ( ptr -- ptr )
  cell+  dup end = if drop buffer then ;

: put ( n -- )
  full? abort" buffer full"
  \ begin full? while pause repeat
  tail @ !  tail @ next tail !   1 used +! ;

: get ( -- n )
  empty? abort" buffer empty"
  \ begin empty? while pause repeat
  head @ @  head @ next head !  -1 used +! ;


module FIFO
  use fifo_nodes
! fifo_nodes must define the type fifo_node, with the two field
! next and valid, for queue handling, while the field datum depends
! on the usage (see [[FIFO (usage)]] for an example)
!  type fifo_node
!     integer :: datum
!     ! the next part is not variable and must be present
!     type(fifo_node), pointer :: next
!     logical :: valid
!  end type fifo_node

  type fifo_head
     type(fifo_node), pointer :: head, tail
  end type fifo_head

contains

  subroutine new_fifo(h)
    type(fifo_head), intent(out) :: h
    nullify(h%head)
    nullify(h%tail)
  end subroutine new_fifo

  subroutine fifo_enqueue(h, n)
    type(fifo_head), intent(inout) :: h
    type(fifo_node), intent(inout), target :: n

    if ( associated(h%tail) ) then
       h%tail%next => n
       h%tail => n
    else
       h%tail => n
       h%head => n
    end if

    nullify(n%next)
  end subroutine fifo_enqueue

  subroutine fifo_dequeue(h, n)
    type(fifo_head), intent(inout) :: h
    type(fifo_node), intent(out), target :: n

    if ( associated(h%head) ) then
       n = h%head
       if ( associated(n%next) ) then
          h%head => n%next
       else
          nullify(h%head)
          nullify(h%tail)
       end if
       n%valid = .true.
    else
       n%valid = .false.
    end if
    nullify(n%next)
  end subroutine fifo_dequeue

  function fifo_isempty(h) result(r)
    logical :: r
    type(fifo_head), intent(in) :: h
    if ( associated(h%head) ) then
       r = .false.
    else
       r = .true.
    end if
  end function fifo_isempty

end module FIFO


Module Program
    Sub Main()
        Dim s = "
Module Program
    Sub Main()
        Dim s = {0}{1}{0}
        Console.WriteLine(s, ChrW(34), s)
    End Sub
End Module"
        Console.WriteLine(s, ChrW(34), s)
    End Sub
End Module


let str => import 'strings';
let v => "let str => import 'strings';\nlet v => {q};\nstr.format v v -- io.writeln io.stdout;";
str.format v v -- io.writeln io.stdout;


program queue;
 {$IFDEF FPC}{$MODE DELPHI}{$IFDEF WINDOWS}{$APPTYPE CONSOLE}{$ENDIF}{$ENDIF}
 {$ASSERTIONS ON}
uses Generics.Collections;

var
  lQueue: TQueue<Integer>;
begin
  lQueue := TQueue<Integer>.Create;
  try
    lQueue.EnQueue(1);
    lQueue.EnQueue(2);
    lQueue.EnQueue(3);
    Write(lQueue.DeQueue:2);   // 1
    Write(lQueue.DeQueue:2);   // 2
    Writeln(lQueue.DeQueue:2); // 3
    Assert(lQueue.Count = 0, 'Queue is not empty'); // should be empty
  finally
    lQueue.Free;
  end;
end.


' FB 1.05.0 Win64

' queue_rosetta.bi
' simple generic Queue type

#Define Queue(T) Queue_##T

#Macro Declare_Queue(T)
Type Queue(T)
 Public:
    Declare Constructor()
    Declare Destructor()
    Declare Property capacity As Integer
    Declare Property count As Integer
    Declare Property empty As Boolean
    Declare Property front As T
    Declare Function pop() As T
    Declare Sub push(item As T)
  Private:
    a(any) As T
    count_ As Integer = 0
    Declare Function resize(size As Integer) As Integer
End Type

Constructor Queue(T)()
  Redim a(0 To 0) '' create a default T instance for various purposes
End Constructor

Destructor Queue(T)()
  Erase a
End Destructor

Property Queue(T).capacity As Integer
  Return UBound(a)
End Property

Property Queue(T).count As Integer
  Return count_
End Property

Property Queue(T).empty As Boolean
  Return count_ = 0
End Property

Property Queue(T).front As T
  If count_ > 0 Then
    Return a(1)
  End If
  Print "Error: Attempted to access 'front' element of an empty queue"
  Return a(0)  '' return default element
End Property

Function Queue(T).pop() As T
  If count_ > 0 Then
    Dim value As T = a(1)
    If count_ > 1 Then  '' move remaining elements to fill space vacated
      For i As Integer = 2 To count_
        a(i - 1) = a(i)
      Next
    End If
    a(count_) = a(0)  '' zero last element
    count_ -= 1
    Return value
  End If
  Print "Error: Attempted to remove 'front' element of an empty queue"
  Return a(0)  '' return default element
End Function

Sub Queue(T).push(item As T)
  Dim size As Integer = UBound(a)
  count_ += 1
  If count_ >  size Then
    size = resize(size)
    Redim Preserve a(0 to size)
  End If
  a(count_) = item
End Sub

Function Queue(T).resize(size As Integer) As Integer
  If size = 0 Then
    size = 4
  ElseIf size <= 32 Then
    size  = 2 * size
  Else
    size += 32
  End If
  Return size
End Function
#EndMacro


import "/fmt" for Fmt

var a = "import $c/fmt$c for Fmt$c$cvar a = $q$cFmt.lprint(a, [34, 34, 10, 10, a, 10])"
Fmt.lprint(a, [34, 34, 10, 10, a, 10])


.global _start;_start:mov $p,%rsi;mov $1,%rax;mov $1,%rdi;mov $255,%rdx;syscall;mov $q,%rsi;mov $1,%rax;mov $1,%rdx;syscall;mov $p,%rsi;mov $1,%rax;mov $255,%rdx;syscall;mov $q,%rsi;mov $1,%rax;mov $1,%rdx;syscall;mov $60,%rax;syscall;q:.byte 34;p:.ascii ".global _start;_start:mov $p,%rsi;mov $1,%rax;mov $1,%rdi;mov $255,%rdx;syscall;mov $q,%rsi;mov $1,%rax;mov $1,%rdx;syscall;mov $p,%rsi;mov $1,%rax;mov $255,%rdx;syscall;mov $q,%rsi;mov $1,%rax;mov $1,%rdx;syscall;mov $60,%rax;syscall;q:.byte 34;p:.ascii "


Enqueue := function(v, x)
    Add(v[1], x);
end;

Dequeue := function(v)
    if IsEmpty(v[2]) then
        if IsEmpty(v[1]) then
            return fail;
        else
            v[2] := Reversed(v[1]);
            v[1] := [];
        fi;
    fi;
    return Remove(v[2]);
end;

# a new queue
v := [[], []];

Enqueue(v, 3);
Enqueue(v, 4);
Enqueue(v, 5);
Dequeue(v);
# 3
Enqueue(v, 6);
Dequeue(v);
# 4
Dequeue(v);
# 5
Dequeue(v);
# 6
Dequeue(v);
# fail


package queue

// int queue
// the zero object is a valid queue ready to be used.
// items are pushed at tail, popped at head.
// tail = -1 means queue is full
type Queue struct {
    b []string
    head, tail int
}

func (q *Queue) Push(x string) {
    switch {
    // buffer full. reallocate.
    case q.tail < 0:
        next := len(q.b)
        bigger := make([]string, 2*next)
        copy(bigger[copy(bigger, q.b[q.head:]):], q.b[:q.head])
        bigger[next] = x
        q.b, q.head, q.tail = bigger, 0, next+1
    // zero object. make initial allocation.
    case len(q.b) == 0:
        q.b, q.head, q.tail = make([]string, 4), 0 ,1
        q.b[0] = x
    // normal case
    default:
        q.b[q.tail] = x
        q.tail++
        if q.tail == len(q.b) {
            q.tail = 0
        }
        if q.tail == q.head {
            q.tail = -1
        }
    }
}

func (q *Queue) Pop() (string, bool) {
    if q.head == q.tail {
        return "", false
    }
    r := q.b[q.head]
    if q.tail == -1 {
        q.tail = q.head
    }
    q.head++
    if q.head == len(q.b) {
        q.head = 0
    }
    return r, true
}

func (q *Queue) Empty() bool {
    return q.head == q.tail
}


class Queue {
    private List buffer

    public Queue(List buffer =  new LinkedList()) {
        assert buffer != null
        assert buffer.empty
        this.buffer = buffer
    }

    def push (def item) { buffer << item }
    final enqueue = this.&push

    def pop() {
        if (this.empty) throw new NoSuchElementException('Empty Queue')
        buffer.remove(0)
    }
    final dequeue = this.&pop

    def getEmpty() { buffer.empty }

    String toString() { "Queue:${buffer}" }
}


data Fifo a = F [a] [a]

emptyFifo :: Fifo a
emptyFifo = F [] []

push :: Fifo a -> a -> Fifo a
push (F input output) item = F (item:input) output

pop :: Fifo a -> (Maybe a, Fifo a)
pop (F input (item:output)) = (Just item, F input output)
pop (F []    []           ) = (Nothing, F [] [])
pop (F input []           ) = pop (F [] (reverse input))

isEmpty :: Fifo a -> Bool
isEmpty (F [] []) = True
isEmpty _         = False


# Use a record to hold a Queue, using a list as the concrete implementation
record Queue(items)

procedure make_queue ()
  return Queue ([])
end

procedure queue_push (queue, item)
  put (queue.items, item)
end

# if the queue is empty, this will 'fail' and return nothing
procedure queue_pop (queue)
  return pop (queue.items)
end

procedure queue_empty (queue)
  return *queue.items = 0
end

# procedure to test class
procedure main ()
  queue := make_queue()

  # add the numbers 1 to 5
  every (item := 1 to 5) do
    queue_push (queue, item)

  # pop them in the added order, and show a message when queue is empty
  every (1 to 6) do {
    write ("Popped value: " || queue_pop (queue))
    if (queue_empty (queue)) then write ("empty queue")
  }
end


queue_fifo_=: ''

pop_fifo_=: verb define
  r=. {. ::] queue
  queue=: }.queue
  r
)

push_fifo_=: verb define
  queue=: queue,y
  y
)

isEmpty_fifo_=: verb define
  0=#queue
)


public class Queue<E>{
    Node<E> head = null, tail = null;

    static class Node<E>{
        E value;
        Node<E> next;

        Node(E value, Node<E> next){
            this.value= value;
            this.next= next;
        }

    }

    public Queue(){
    }

    public void enqueue(E value){ //standard queue name for "push"
        Node<E> newNode= new Node<E>(value, null);
        if(empty()){
            head= newNode;
        }else{
            tail.next = newNode;
        }
        tail= newNode;
    }

    public E dequeue() throws java.util.NoSuchElementException{//standard queue name for "pop"
        if(empty()){
            throw new java.util.NoSuchElementException("No more elements.");
        }
        E retVal= head.value;
        head= head.next;
        return retVal;
    }

    public boolean empty(){
        return head == null;
    }
}


var fifo = [];
fifo.push(42); // Enqueue.
fifo.push(43);
var x = fifo.shift(); // Dequeue.
alert(x); // 42


# An empty queue:
def fifo: [];

def push(e): [e] + .;

def pop: [.[0], .[1:]];

def pop_or_error: if length == 0 then error("pop_or_error") else pop end;

def empty: length == 0;


struct Queue{T}
    a::Array{T,1}
end

Queue() = Queue(Any[])
Queue(a::DataType) = Queue(a[])
Queue(a) = Queue(typeof(a)[])

Base.isempty(q::Queue) = isempty(q.a)

function Base.pop!(q::Queue{T}) where {T}
    !isempty(q) || error("queue must be non-empty")
    pop!(q.a)
end

function Base.push!(q::Queue{T}, x::T) where {T}
    pushfirst!(q.a, x)
    return q
end

function Base.push!(q::Queue{Any}, x::T) where {T}
    pushfirst!(q.a, x)
    return q
end


{ include ..\Utilitys.tlhy }
"..\Utilitys.tlhy" load

:push!   { l i -- l&i }
    0 put
;

:empty?  { l -- flag }
    len not   { len 0 equal }
;

:pop!    { l -- l-1 }
    empty? (
        ["Empty"]
        [pop swap]
    ) if
;

( ) { empty queue }

1 push! 2 push! 3 push!
pop! ? pop! ? pop! ? pop! ?

"End " input


// version 1.1.2

import java.util.LinkedList

class Queue<E> {
    private val data = LinkedList<E>()

    val size get() = data.size

    val empty get() = size == 0

    fun push(element: E) = data.add(element)

    fun pop(): E {
        if (empty) throw RuntimeException("Can't pop elements from an empty queue")
        return data.removeFirst()
    }

   val top: E
        get() {
            if (empty) throw RuntimeException("Empty queue can't have a top element")
            return data.first()
        }

    fun clear() = data.clear()

    override fun toString() = data.toString()
}

fun main(args: Array<String>) {
    val q = Queue<Int>()
    (1..5).forEach { q.push(it) }
    println(q)
    println("Size of queue = ${q.size}")
    print("Popping: ")
    (1..3).forEach { print("${q.pop()} ") }
    println("\nRemaining in queue: $q")
    println("Top element is now ${q.top}")
    q.clear()
    println("After clearing, queue is ${if(q.empty) "empty" else "not empty"}")
    try {
        q.pop()
    }
    catch (e: Exception) {
        println(e.message)
    }
}


define myqueue => type {
    data store = list

    public onCreate(...) => {
        if(void != #rest) => {
            with item in #rest do .`store`->insert(#item)
        }
    }

    public push(value) => .`store`->insertLast(#value)

    public pop => {
        handle => {
            .`store`->removefirst
        }

        return .`store`->first
    }

    public isEmpty => (.`store`->size == 0)
}


Queue = {}

function Queue.new()
    return { first = 0, last = -1 }
end

function Queue.push( queue, value )
    queue.last = queue.last + 1
    queue[queue.last] = value
end

function Queue.pop( queue )
    if queue.first > queue.last then
        return nil
    end

    local val = queue[queue.first]
    queue[queue.first] = nil
    queue.first = queue.first + 1
    return val
end

function Queue.empty( queue )
    return queue.first > queue.last
end


Module Checkit {
      a=Stack
      Stack a {
            Data 100,200, 300
      }
      Stack a {
            While not empty {
                  Read N
                  Print N
            }
      }
}
Checkit


EmptyQ[a_] := Length[a] == 0
SetAttributes[Push, HoldAll]; Push[a_, elem_] := AppendTo[a, elem]
SetAttributes[Pop, HoldAllComplete]; Pop[a_] := If[EmptyQ[a], False, b = First[a]; Set[a, Most[a]]; b]


myfifo = {};

% push
myfifo{end+1} = x;

% pop
x = myfifo{1};  myfifo{1} = [];

% empty
isempty(myfifo)


defstruct(queue(in=[], out=[]))$

enqueue(x, q) := ([email protected]: cons(x, [email protected]), done)$

dequeue(q) := (if not emptyp([email protected]) then first([first([email protected]), [email protected]: rest([email protected])])
elseif emptyp([email protected]) then 'fail
else ([email protected]: reverse([email protected]), [email protected]: [], first([first([email protected]), [email protected]: rest([email protected])])))$

q:new(queue);    /* queue([], []) */
enqueue(1, q)$
enqueue(2, q)$
enqueue(3, q)$
dequeue(q);      /* 1 */
enqueue(4, q)$
dequeue(q);      /* 2 */
dequeue(q);      /* 3 */
dequeue(q);      /* 4 */
dequeue(q);      /* fail */


class FIFO
	declare contents

	// define constructors for FIFO objects
	def FIFO()
		this.contents = {}
	end
	def FIFO(contents)
		this.contents = contents
	end

	// define methods for this class
	def push(value)
		contents.append(value)
	end
	def pop()
		if !this.empty()
			value = contents[len(contents) - 1]
			contents.remove(len(contents) - 1)
			return value
		else
			// we could throw our own exception here but
			// we'll return null instead
			return null
		end
	end
	def length()
		return len(contents)
	end
	def extend(itemlist)
		contents += itemlist
	end
	def empty()
		return len(contents) = 0
	end

	// define operators for this class
	def toString()
		return str(contents)
	end
	def operator+(other)
		return this.contents + other.contents
	end
	def operator*(n)
		return this.contents * n
	end
	def operator=(other)
		return this.contents = other.contents
	end
end


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

mqueue = ArrayDeque()

viewQueue(mqueue)

a = "Fred"
mqueue.push('')      /* Puts an empty line onto the queue */
mqueue.push(a 2)     /* Puts "Fred 2" onto the queue */
viewQueue(mqueue)

a = "Toft"
mqueue.add(a 2)      /* Enqueues "Toft 2" */
mqueue.add('')       /* Enqueues an empty line behind the last */
viewQueue(mqueue)

loop q_ = 1 while mqueue.size > 0
  parse mqueue.pop.toString line
  say q_.right(3)':' line
  end q_
viewQueue(mqueue)

return

method viewQueue(mqueue = Deque) private static

   If mqueue.size = 0 then do
    Say 'Queue is empty'
    end
  else do
    Say 'There are' mqueue.size 'elements in the queue'
    end

  return


type

  Node[T] = ref object
    value: T
    next: Node[T]

  Queue*[T] = object
    head, tail: Node[T]
    length: Natural

func initQueue*[T](): Queue[T] = Queue[T]()

func len*(queue: Queue): Natural =
  queue.length

func isEmpty*(queue: Queue): bool {.inline.} =
  queue.len == 0

func push*[T](queue: var Queue[T]; value: T) =
  let node = Node[T](value: value, next: nil)
  if queue.isEmpty: queue.head = node
  else: queue.tail.next = node
  queue.tail = node
  inc queue.length

func pop*[T](queue: var Queue[T]): T =
  if queue.isEmpty:
    raise newException(ValueError, "popping from empty queue.")
  result = queue.head.value
  queue.head = queue.head.next
  dec queue.length
  if queue.isEmpty: queue.tail = nil

when isMainModule:

  var fifo = initQueue[int]()

  fifo.push(26)
  fifo.push(99)
  fifo.push(2)
  echo "Fifo size: ", fifo.len()
  try:
    echo "Popping: ", fifo.pop()
    echo "Popping: ", fifo.pop()
    echo "Popping: ", fifo.pop()
    echo "Popping: ", fifo.pop()
  except ValueError:
    echo "Exception catched: ", getCurrentExceptionMsg()


module FIFO : sig
  type 'a fifo
  val empty: 'a fifo
  val push: fifo:'a fifo -> item:'a -> 'a fifo
  val pop: fifo:'a fifo -> 'a * 'a fifo
  val is_empty: fifo:'a fifo -> bool
end = struct
  type 'a fifo = 'a list * 'a list
  let empty = [], []
  let push ~fifo:(input,output) ~item = (item::input,output)
  let is_empty ~fifo =
    match fifo with
    | [], [] -> true
    | _ -> false
  let rec pop ~fifo =
    match fifo with
    | input, item :: output -> item, (input,output)
    | [], [] -> failwith "empty fifo"
    | input, [] -> pop ([], List.rev input)
end


Object Class new: Queue(mutable l)

Queue method: initialize  ListBuffer new := l ;
Queue method: empty       @l isEmpty ;
Queue method: push        @l add ;
Queue method: pop         @l removeFirst ;


'==========
Class Queue
'==========

 'FIRST IN FIRST OUT

bstring buf 'buffer to hold queue content
int    bg   'buffer base offset
int i       'indexer
int le      'length of buffer

method constructor()
====================
buf=""
le=0
bg=0
i=0
end method

method destructor()
===================
del buf
le=0
bg=0
i=0
end method

method Encodelength(int ls)
===========================
int p at (i+strptr buf)
p=ls
i+=sizeof int
end method

method push(string s)
=====================
int ls=len s
if i+ls+8>le then
  buf+=nuls 8000+ls*2 'extend buf
  le=len buf
end if
EncodeLength ls 'length of input s
mid buf,i+1,s   'append input s
i+=ls
end method

method popLength() as int
=========================
if bg>=i then return -1 'buffer empty
int p at (bg+strptr buf)
bg+=sizeof int
return p
end method

method pop(string *s) as int
============================
int ls=popLength
if ls<0 then s="" : return ls 'empty buffer
s=mid buf,bg+1,ls
bg+=ls
'cleanup buffer
if bg>1e6 then
  buf=mid buf,bg+1
  le=len buf
  i-=bg 'shrink buf
  bg=0
end if
end method

method clear()
==============
buf=""
le=0
bg=0
i=0
end method

end class 'Queue

'====
'DEMO
'====

new Queue  fifo
string     s
'
fifo.push "HumptyDumpty"
fifo.push "Sat on a wall"
'
int er
do
  er=fifo.pop s
  if er then print "(buffer empty)" : exit do
  print s
loop

del fifo


declare
  fun {NewQueue}
     Stream
     WritePort = {Port.new Stream}
     ReadPos = {NewCell Stream}
  in
     WritePort#ReadPos
  end

  proc {Push WritePort#_ Value}
     {Port.send WritePort Value}
  end

  fun {Empty _#ReadPos}
     %% the queue is empty if the value at the current
     %% read position is not determined
     {Not {IsDet @ReadPos}}
  end

  fun {Pop _#ReadPos}
     %% blocks if empty
     case @ReadPos of X|Xr then
        ReadPos := Xr
        X
     end
  end

  Q = {NewQueue}
in
  {Show {Empty Q}}
  {Push Q 42}
  {Show {Empty Q}}
  {Show {Pop Q}}
  {Show {Empty Q}}


program fifo(input, output);

type
 pNode = ^tNode;
 tNode = record
          value: integer;
          next:  pNode;
         end;

 tFifo = record
          first, last: pNode;
         end;

procedure initFifo(var fifo: tFifo);
 begin
  fifo.first := nil;
  fifo.last := nil
 end;

procedure pushFifo(var fifo: tFifo; value: integer);
 var
  node: pNode;
 begin
  new(node);
  node^.value := value;
  node^.next := nil;
  if fifo.first = nil
   then
    fifo.first := node
   else
    fifo.last^.next := node;
  fifo.last := node
 end;

function popFifo(var fifo: tFifo; var value: integer): boolean;
 var
  node: pNode;
 begin
  if fifo.first = nil
   then
    popFifo := false
   else
    begin
     node := fifo.first;
     fifo.first := fifo.first^.next;
     value := node^.value;
     dispose(node);
     popFifo := true
    end
 end;

procedure testFifo;
 var
  fifo: tFifo;
 procedure testpop(expectEmpty: boolean; expectedValue: integer);
  var
   i: integer;
  begin
   if popFifo(fifo, i)
    then
     if expectEmpty
      then
       writeln('Error! Expected empty, got ', i, '.')
      else
       if i = expectedValue
        then
         writeln('Ok, got ', i, '.')
        else
         writeln('Error! Expected ', expectedValue, ', got ', i, '.')
    else
     if expectEmpty
       then
        writeln('Ok, fifo is empty.')
       else
        writeln('Error! Expected ', expectedValue, ', found fifo empty.')
  end;
 begin
  initFifo(fifo);
  pushFifo(fifo, 2);
  pushFifo(fifo, 3);
  pushFifo(fifo, 5);
  testpop(false, 2);
  pushFifo(fifo, 7);
  testpop(false, 3);
  testpop(false, 5);
  pushFifo(fifo, 11);
  testpop(false, 7);
  testpop(false, 11);
  pushFifo(fifo, 13);
  testpop(false, 13);
  testpop(true, 0);
  pushFifo(fifo, 17);
  testpop(false, 17);
  testpop(true, 0)
 end;

begin
 writeln('Testing fifo implementation ...');
 testFifo;
 writeln('Testing finished.')
end.


use Carp;
sub mypush (\@@) {my($list,@things)=@_; push @$list, @things}
sub mypop  (\@)  {my($list)=@_; @$list or croak "Empty"; shift @$list }
sub empty  (@)   {not @_}


with javascript_semantics
sequence queue = {}

procedure push_item(object what)
    queue = append(queue,what)
end procedure

function pop_item()
    object what = queue[1]
    queue = queue[2..$]
    return what
end function

function empty()
    return length(queue)=0
end function


include ..\Utilitys.pmt

def push    /# l i -- l&i #/
    0 put
enddef

def empty?  /# l -- flag #/
    len 0 ==
enddef

def pop     /# l -- l-1 #/
    empty? if
        "Empty"
    else
        head swap tail nip swap
    endif
enddef

( ) /# empty queue #/

1 push 2 push 3 push
pop ? pop ? pop ? pop ?


class Fifo {
  private $data = array();
  public function push($element){
    array_push($this->data, $element);
  }
  public function pop(){
    if ($this->isEmpty()){
      throw new Exception('Attempt to pop from an empty queue');
    }
    return array_shift($this->data);
  }

  //Alias functions
  public function enqueue($element) { $this->push($element); }
  public function dequeue() { return $this->pop(); }

  //Note: PHP prevents a method name of 'empty'
  public function isEmpty(){
    return empty($this->data);
  }
}


go =>
  println("Test 1"),
  queue_test1,
  nl.

empty(Q) => Q = [].
push(Queue, Value) = Q2 =>
  Q2 = [Value] ++ Queue.
pop(Q,_) = _, Q==[] ; var(Q) =>
   throw $error(empty_queue,pop,'Q'=Q).
pop(Queue,Q2) = Queue.last() =>
   Q2 = [Queue[I] : I in 1..Queue.len-1].

queue_test1 =>

    % create an empty queue
    println("Start test 2"),
    empty(Q0),
    printf("Create queue %w%n%n", Q0),

    % add numbers 1 and 2
    println("Add numbers 1 and 2 : "),
    Q1 = Q0.push(1),
    Q2 = Q1.push(2),

    % display queue
    printf("Q2: %w\n\n", Q2),

    % pop element
    V = Q2.pop(Q3),

    % display results
    printf("Pop : Value: %w Queue: %w\n\n", V, Q3),

    % test the queue
    print("Test of the queue: "),
    ( Q3.empty() -> println("Queue empty"); println("Queue not empty") ),
    nl,

    % pop the elements
    print("Pop the queue : "),
    V1 = Q3.pop(Q4),
    printf("Value %w Queue : %w%n%n", V1, Q4),

    println("Pop empty queue:"),
    catch(_V = Q4.pop(_Q5),Exception,println(Exception)),
    nl,

    println("\nEnd of tests.").


with Ada.Text_IO; use Ada.Text_IO;
with Ada.Numerics.Real_Arrays; use Ada.Numerics.Real_Arrays;
with Ada.Numerics.Generic_Elementary_Functions;
procedure QR is

   procedure Show (mat : Real_Matrix) is
      package FIO is new Ada.Text_IO.Float_IO (Float);
   begin
      for row in mat'Range (1) loop
         for col in mat'Range (2) loop
            FIO.Put (mat (row, col), Exp => 0, Aft => 4, Fore => 5);
         end loop;
         New_Line;
      end loop;
   end Show;

   function GetCol (mat : Real_Matrix; n : Integer) return Real_Matrix is
      column : Real_Matrix (mat'Range (1), 1 .. 1);
   begin
      for row in mat'Range (1) loop
         column (row, 1) := mat (row, n);
      end loop;
      return column;
   end GetCol;

   function Mag (mat : Real_Matrix) return Float is
      sum : Real_Matrix := Transpose (mat) * mat;
      package Math is new Ada.Numerics.Generic_Elementary_Functions
         (Float);
   begin
      return Math.Sqrt (sum (1, 1));
   end Mag;

   function eVect (col : Real_Matrix; n : Integer) return Real_Matrix is
      vect : Real_Matrix (col'Range (1), 1 .. 1);
   begin
      for row in col'Range (1) loop
         if row /= n then vect (row, 1) := 0.0;
         else vect (row, 1) := 1.0; end if;
      end loop;
      return vect;
   end eVect;

   function Identity (n : Integer) return Real_Matrix is
      mat : Real_Matrix (1 .. n, 1 .. n) := (1 .. n => (others => 0.0));
   begin
      for i in Integer range 1 .. n loop mat (i, i) := 1.0; end loop;
      return mat;
   end Identity;

   function Chop (mat : Real_Matrix; n : Integer) return Real_Matrix is
      small : Real_Matrix (n .. mat'Length (1), n .. mat'Length (2));
   begin
      for row in small'Range (1) loop
         for col in small'Range (2) loop
            small (row, col) := mat (row, col);
         end loop;
      end loop;
      return small;
   end Chop;

   function H_n (inmat : Real_Matrix; n : Integer)
      return Real_Matrix is
      mat : Real_Matrix := Chop (inmat, n);
      col : Real_Matrix := GetCol (mat, n);
      colT : Real_Matrix (1 .. 1, mat'Range (1));
      H : Real_Matrix := Identity (mat'Length (1));
      Hall : Real_Matrix := Identity (inmat'Length (1));
   begin
      col := col - Mag (col) * eVect (col, n);
      col := col / Mag (col);
      colT := Transpose (col);
      H := H - 2.0 * (col * colT);
      for row in H'Range (1) loop
         for col in H'Range (2) loop
            Hall (n - 1 + row, n - 1 + col) := H (row, col);
         end loop;
      end loop;
      return Hall;
   end H_n;

   A : constant Real_Matrix (1 .. 3, 1 .. 3) := (
      (12.0, -51.0, 4.0),
      (6.0, 167.0, -68.0),
      (-4.0, 24.0, -41.0));
   Q1, Q2, Q3, Q, R: Real_Matrix (1 .. 3, 1 .. 3);
begin
   Q1 := H_n (A, 1);
   Q2 := H_n (Q1 * A, 2);
   Q3 := H_n (Q2 * Q1* A, 3);
   Q := Transpose (Q1) * Transpose (Q2) * TransPose(Q3);
   R := Q3 * Q2 * Q1 * A;
   Put_Line ("Q:"); Show (Q);
   Put_Line ("R:"); Show (R);
end QR;


(off Queue)                # Clear Queue
(fifo 'Queue 1)            # Store number '1'
(fifo 'Queue 'abc)         # an internal symbol 'abc'
(fifo 'Queue "abc")        # a transient symbol "abc"
(fifo 'Queue '(a b c))     # and a list (a b c)
Queue                      # Show the queue


/* To push a node onto the end of the queue. */
push: procedure (tail);
   declare tail handle (node), t handle (node);
   t = new(:node:);
   get (t => value);
   if tail ^= bind(:null, node:) then
      tail => link = t;
      /* If the queue was non-empty, points the tail of the queue */
      /* to the new node. */
   tail = t; /* Point "tail" at the end of the queue. */
   tail => link = bind(:node, null:);
end push;

/* To pop a node from the head of the queue. */
pop: procedure (head, val);
   declare head handle (node), val fixed binary;
   if head = bind(:node, null:) then signal error;
   val = head => value;
   head = head => pointer; /* pops the top node. */
   if head = bind(:node, null:) then tail = head;
      /* (If the queue is now empty, make tail null also.) */
end pop;

/* Queue status: the EMPTY function, returns true for empty queue. */
empty: procedure (h) returns (bit(1));
   declare h handle (Node);
   return (h = bind(:Node, null:) );
end empty;


)abbrev package TESTP TestPackage
TestPackage(R:Join(Field,RadicalCategory)): with
    unitVector: NonNegativeInteger -> Vector(R)
    "/": (Vector(R),R) -> Vector(R)
    "^": (Vector(R),NonNegativeInteger) -> Vector(R)
    solveUpperTriangular: (Matrix(R),Vector(R)) -> Vector(R)
    signValue: R -> R
    householder: Vector(R) -> Matrix(R)
    qr: Matrix(R) -> Record(q:Matrix(R),r:Matrix(R))
    lsqr: (Matrix(R),Vector(R)) -> Vector(R)
    polyfit: (Vector(R),Vector(R),NonNegativeInteger) -> Vector(R)
  == add
    unitVector(dim) ==
      out := new(dim,[email protected])$Vector(R)
      out(1) := [email protected]
      out
    v:Vector(R) / a:R == map((vi:R):R +-> vi/a, v)$Vector(R)
    v:Vector(R) ^ n:NonNegativeInteger == map((vi:R):R +-> vi^n, v)$Vector(R)
    solveUpperTriangular(r,b) ==
      n := ncols r
      x := new(n,[email protected])$Vector(R)
      for k in n..1 by -1 repeat
        index := min(n,k+1)
	x(k) := (b(k)-reduce("+",subMatrix(r,k,k,index,n)*x.(index..n)))/r(k,k)
      x
    signValue(r) ==
      R has (sign: R -> Integer) => coerce(sign(r)$R)$R
      zero? r => r
      if sqrt(r*r) = r then 1 else -1
    householder(a) ==
      m := #a
      u := a + length(a)*signValue(a(1))*unitVector(m)
      v := u/u(1)
      beta := (1+1)/dot(v,v)
      scalarMatrix(m,1) - beta*transpose(outerProduct(v,v))
    qr(a) ==
      (m,n) := (nrows a, ncols a)
      qm := scalarMatrix(m,1)
      rm := copy a
      for i in 1..(if m=n then n-1 else n) repeat
        x := column(subMatrix(rm,i,m,i,i),1)
	h := scalarMatrix(m,1)
	setsubMatrix!(h,i,i,householder x)
	qm := qm*h
	rm := h*rm
      [qm,rm]
    lsqr(a,b) ==
      dc := qr a
      n := ncols(dc.r)
      solveUpperTriangular(subMatrix(dc.r,1,n,1,n),transpose(dc.q)*b)
    polyfit(x,y,n) ==
      a := new(#x,n+1,[email protected])$Matrix(R)
      for j in 0..n repeat
        setColumn!(a,j+1,x^j)
      lsqr(a,y)


      *FLOAT 64
      @% = &2040A
      INSTALL @lib$+"ARRAYLIB"

      REM Test matrix for QR decomposition:
      DIM A(2,2)
      A() = 12, -51,   4, \
      \      6, 167, -68, \
      \     -4,  24, -41

      REM Do the QR decomposition:
      DIM Q(2,2), R(2,2)
      PROCqrdecompose(A(), Q(), R())
      PRINT "Q:"
      PRINT Q(0,0), Q(0,1), Q(0,2)
      PRINT Q(1,0), Q(1,1), Q(1,2)
      PRINT Q(2,0), Q(2,1), Q(2,2)
      PRINT "R:"
      PRINT R(0,0), R(0,1), R(0,2)
      PRINT R(1,0), R(1,1), R(1,2)
      PRINT R(2,0), R(2,1), R(2,2)

      REM Test data for least-squares solution:
      DIM x(10) : x() = 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10
      DIM y(10) : y() = 1, 6, 17, 34, 57, 86, 121, 162, 209, 262, 321

      REM Do the least-squares solution:
      DIM a(10,2), q(10,10), r(10,2), t(10,10), b(10), z(2)
      FOR i% = 0 TO 10
        FOR j% = 0 TO 2
          a(i%,j%) = x(i%) ^ j%
        NEXT
      NEXT
      PROCqrdecompose(a(), q(), r())
      PROC_transpose(q(),t())
      b() = t() . y()
      FOR k% = 2 TO 0 STEP -1
        s = 0
        IF k% < 2 THEN
          FOR j% = k%+1 TO 2
            s += r(k%,j%) * z(j%)
          NEXT
        ENDIF
        z(k%) = (b(k%) - s) / r(k%,k%)
      NEXT k%
      PRINT '"Least-squares solution:"
      PRINT z(0), z(1), z(2)
      END

      DEF PROCqrdecompose(A(), Q(), R())
      LOCAL i%, k%, m%, n%, H()
      m% = DIM(A(),1) : n% = DIM(A(),2)
      DIM H(m%,m%)
      FOR i% = 0 TO m% : Q(i%,i%) = 1 : NEXT
      WHILE n%
        PROCqrstep(n%, k%, A(), H())
        A() = H() . A()
        Q() = Q() . H()
        k% += 1
        m% -= 1
        n% -= 1
      ENDWHILE
      R() = A()
      ENDPROC

      DEF PROCqrstep(n%, k%, A(), H())
      LOCAL a(), h(), i%, j%
      DIM a(n%,0), h(n%,n%)
      FOR i% = 0 TO n% : a(i%,0) = A(i%+k%,k%) : NEXT
      PROChouseholder(h(), a())
      H() = 0  : H(0,0) = 1
      FOR i% = 0 TO n%
        FOR j% = 0 TO n%
          H(i%+k%,j%+k%) = h(i%,j%)
        NEXT
      NEXT
      ENDPROC

      REM Create the Householder matrix for the supplied column vector:
      DEF PROChouseholder(H(), a())
      LOCAL e(), u(), v(), vt(), vvt(), I(), d()
      LOCAL i%, n% : n% = DIM(a(),1)
      REM Create the scaled standard basis vector e():
      DIM e(n%,0) : e(0,0) = SGN(a(0,0)) * MOD(a())
      REM Create the normal vector u():
      DIM u(n%,0) : u() = a() + e()
      REM Normalise with respect to the first element:
      DIM v(n%,0) : v() = u() / u(0,0)
      REM Get the transpose of v() and its dot product with v():
      DIM vt(0,n%), d(0) : PROC_transpose(v(), vt()) : d() = vt() . v()
      REM Get the product of v() and vt():
      DIM vvt(n%,n%) : vvt() = v() . vt()
      REM Create an identity matrix I():
      DIM I(n%,n%) : FOR i% = 0 TO n% : I(i%,i%) = 1 : NEXT
      REM Create the Householder matrix H() = I - 2/vt()v() v()vt():
      vvt() *= 2 / d(0) : H() = I() - vvt()
      ENDPROC


#include <stdio.h>
#include <stdlib.h>
#include <math.h>

typedef struct {
	int m, n;
	double ** v;
} mat_t, *mat;

mat matrix_new(int m, int n)
{
	mat x = malloc(sizeof(mat_t));
	x->v = malloc(sizeof(double*) * m);
	x->v[0] = calloc(sizeof(double), m * n);
	for (int i = 0; i < m; i++)
		x->v[i] = x->v[0] + n * i;
	x->m = m;
	x->n = n;
	return x;
}

void matrix_delete(mat m)
{
	free(m->v[0]);
	free(m->v);
	free(m);
}

void matrix_transpose(mat m)
{
	for (int i = 0; i < m->m; i++) {
		for (int j = 0; j < i; j++) {
			double t = m->v[i][j];
			m->v[i][j] = m->v[j][i];
			m->v[j][i] = t;
		}
	}
}

mat matrix_copy(int n, double a[][n], int m)
{
	mat x = matrix_new(m, n);
	for (int i = 0; i < m; i++)
		for (int j = 0; j < n; j++)
			x->v[i][j] = a[i][j];
	return x;
}

mat matrix_mul(mat x, mat y)
{
	if (x->n != y->m) return 0;
	mat r = matrix_new(x->m, y->n);
	for (int i = 0; i < x->m; i++)
		for (int j = 0; j < y->n; j++)
			for (int k = 0; k < x->n; k++)
				r->v[i][j] += x->v[i][k] * y->v[k][j];
	return r;
}

mat matrix_minor(mat x, int d)
{
	mat m = matrix_new(x->m, x->n);
	for (int i = 0; i < d; i++)
		m->v[i][i] = 1;
	for (int i = d; i < x->m; i++)
		for (int j = d; j < x->n; j++)
			m->v[i][j] = x->v[i][j];
	return m;
}

/* c = a + b * s */
double *vmadd(double a[], double b[], double s, double c[], int n)
{
	for (int i = 0; i < n; i++)
		c[i] = a[i] + s * b[i];
	return c;
}

/* m = I - v v^T */
mat vmul(double v[], int n)
{
	mat x = matrix_new(n, n);
	for (int i = 0; i < n; i++)
		for (int j = 0; j < n; j++)
			x->v[i][j] = -2 *  v[i] * v[j];
	for (int i = 0; i < n; i++)
		x->v[i][i] += 1;

	return x;
}

/* ||x|| */
double vnorm(double x[], int n)
{
	double sum = 0;
	for (int i = 0; i < n; i++) sum += x[i] * x[i];
	return sqrt(sum);
}

/* y = x / d */
double* vdiv(double x[], double d, double y[], int n)
{
	for (int i = 0; i < n; i++) y[i] = x[i] / d;
	return y;
}

/* take c-th column of m, put in v */
double* mcol(mat m, double *v, int c)
{
	for (int i = 0; i < m->m; i++)
		v[i] = m->v[i][c];
	return v;
}

void matrix_show(mat m)
{
	for(int i = 0; i < m->m; i++) {
		for (int j = 0; j < m->n; j++) {
			printf(" %8.3f", m->v[i][j]);
		}
		printf("\n");
	}
	printf("\n");
}

void householder(mat m, mat *R, mat *Q)
{
	mat q[m->m];
	mat z = m, z1;
	for (int k = 0; k < m->n && k < m->m - 1; k++) {
		double e[m->m], x[m->m], a;
		z1 = matrix_minor(z, k);
		if (z != m) matrix_delete(z);
		z = z1;

		mcol(z, x, k);
		a = vnorm(x, m->m);
		if (m->v[k][k] > 0) a = -a;

		for (int i = 0; i < m->m; i++)
			e[i] = (i == k) ? 1 : 0;

		vmadd(x, e, a, e, m->m);
		vdiv(e, vnorm(e, m->m), e, m->m);
		q[k] = vmul(e, m->m);
		z1 = matrix_mul(q[k], z);
		if (z != m) matrix_delete(z);
		z = z1;
	}
	matrix_delete(z);
	*Q = q[0];
	*R = matrix_mul(q[0], m);
	for (int i = 1; i < m->n && i < m->m - 1; i++) {
		z1 = matrix_mul(q[i], *Q);
		if (i > 1) matrix_delete(*Q);
		*Q = z1;
		matrix_delete(q[i]);
	}
	matrix_delete(q[0]);
	z = matrix_mul(*Q, m);
	matrix_delete(*R);
	*R = z;
	matrix_transpose(*Q);
}

double in[][3] = {
	{ 12, -51,   4},
	{  6, 167, -68},
	{ -4,  24, -41},
	{ -1, 1, 0},
	{ 2, 0, 3},
};

int main()
{
	mat R, Q;
	mat x = matrix_copy(3, in, 5);
	householder(x, &R, &Q);

	puts("Q"); matrix_show(Q);
	puts("R"); matrix_show(R);

	// to show their product is the input matrix
	mat m = matrix_mul(Q, R);
	puts("Q * R"); matrix_show(m);

	matrix_delete(x);
	matrix_delete(R);
	matrix_delete(Q);
	matrix_delete(m);
	return 0;
}


% our queue is just [] and empty? is already defined.
/push {exch tadd}.
/pop {uncons exch}.


$Q = New-Object System.Collections.Queue

$Q.Enqueue( 1 )
$Q.Enqueue( 2 )
$Q.Enqueue( 3 )

$Q.Dequeue()
$Q.Dequeue()

$Q.Count -eq 0
$Q.Dequeue()
$Q.Count -eq 0

try
{ $Q.Dequeue() }
catch [System.InvalidOperationException]
{ If ( $_.Exception.Message -eq 'Queue empty.' ) { 'Caught error' } }


F quad(top = 2200)
   V r = [0B] * top
   V ab = [0B] * (top * 2)^2
   L(a) 1 .< top
      L(b) a .< top
         ab[a * a + b * b] = 1B
   V s = 3
   L(c) 1 .< top
      (V s1, s, V s2) = (s, s + 2, s + 2)
      L(d) c + 1 .< top
         I ab[s1]
            r[d] = 1B
         s1 += s2
         s2 += 2
   R enumerate(r).filter((i, val) -> !val & i).map((i, val) -> i)

print(quad())


using System;
using MathNet.Numerics.LinearAlgebra;
using MathNet.Numerics.LinearAlgebra.Double;

class Program
{

    static void Main(string[] args)
    {
        Matrix<double> A = DenseMatrix.OfArray(new double[,]
        {
                {  12,  -51,    4 },
                {   6,  167,  -68 },
                {  -4,   24,  -41 }
        });
        Console.WriteLine("A:");
        Console.WriteLine(A);
        var qr = A.QR();
        Console.WriteLine();
        Console.WriteLine("Q:");
        Console.WriteLine(qr.Q);
        Console.WriteLine();
        Console.WriteLine("R:");
        Console.WriteLine(qr.R);
    }
}


/*
 * g++ -O3 -Wall --std=c++11 qr_standalone.cpp -o qr_standalone
 */
#include <cstdio>
#include <cstdlib>
#include <cstring> // for memset
#include <limits>
#include <iostream>
#include <vector>

#include <math.h>

class Vector;

class Matrix {

public:
  // default constructor (don't allocate)
  Matrix() : m(0), n(0), data(nullptr) {}

  // constructor with memory allocation, initialized to zero
  Matrix(int m_, int n_) : Matrix() {
    m = m_;
    n = n_;
    allocate(m_,n_);
  }

  // copy constructor
  Matrix(const Matrix& mat) : Matrix(mat.m,mat.n) {

    for (int i = 0; i < m; i++)
      for (int j = 0; j < n; j++)
	(*this)(i,j) = mat(i,j);
  }

  // constructor from array
  template<int rows, int cols>
  Matrix(double (&a)[rows][cols]) : Matrix(rows,cols) {

    for (int i = 0; i < m; i++)
      for (int j = 0; j < n; j++)
	(*this)(i,j) = a[i][j];
  }

  // destructor
  ~Matrix() {
    deallocate();
  }

  // access data operators
  double& operator() (int i, int j) {
    return data[i+m*j]; }
  double  operator() (int i, int j) const {
    return data[i+m*j]; }

  // operator assignment
  Matrix& operator=(const Matrix& source) {

    // self-assignment check
    if (this != &source) {
      if ( (m*n) != (source.m * source.n) ) { // storage cannot be reused
	allocate(source.m,source.n);          // re-allocate storage
      }
      // storage can be used, copy data
      std::copy(source.data, source.data + source.m*source.n, data);
    }
    return *this;
  }

  // compute minor
  void compute_minor(const Matrix& mat, int d) {

    allocate(mat.m, mat.n);

    for (int i = 0; i < d; i++)
      (*this)(i,i) = 1.0;
    for (int i = d; i < mat.m; i++)
      for (int j = d; j < mat.n; j++)
	(*this)(i,j) = mat(i,j);

  }

  // Matrix multiplication
  // c = a * b
  // c will be re-allocated here
  void mult(const Matrix& a, const Matrix& b) {

    if (a.n != b.m) {
      std::cerr << "Matrix multiplication not possible, sizes don't match !\n";
      return;
    }

    // reallocate ourself if necessary i.e. current Matrix has not valid sizes
    if (a.m != m or b.n != n)
      allocate(a.m, b.n);

    memset(data,0,m*n*sizeof(double));

    for (int i = 0; i < a.m; i++)
      for (int j = 0; j < b.n; j++)
	for (int k = 0; k < a.n; k++)
	  (*this)(i,j) += a(i,k) * b(k,j);

  }

  void transpose() {
    for (int i = 0; i < m; i++) {
      for (int j = 0; j < i; j++) {
	double t = (*this)(i,j);
	(*this)(i,j) = (*this)(j,i);
	(*this)(j,i) = t;
      }
    }
  }

  // take c-th column of m, put in v
  void extract_column(Vector& v, int c);

  // memory allocation
  void allocate(int m_, int n_) {

    // if already allocated, memory is freed
    deallocate();

    // new sizes
    m = m_;
    n = n_;

    data = new double[m_*n_];
    memset(data,0,m_*n_*sizeof(double));

  } // allocate

  // memory free
  void deallocate() {

    if (data)
      delete[] data;

    data = nullptr;

  }

  int m, n;

private:
  double* data;

}; // struct Matrix

// column vector
class Vector {

public:
  // default constructor (don't allocate)
  Vector() : size(0), data(nullptr) {}

  // constructor with memory allocation, initialized to zero
  Vector(int size_) : Vector() {
    size = size_;
    allocate(size_);
  }

  // destructor
  ~Vector() {
    deallocate();
  }

  // access data operators
  double& operator() (int i) {
    return data[i]; }
  double  operator() (int i) const {
    return data[i]; }

  // operator assignment
  Vector& operator=(const Vector& source) {

    // self-assignment check
    if (this != &source) {
      if ( size != (source.size) ) {   // storage cannot be reused
	allocate(source.size);         // re-allocate storage
      }
      // storage can be used, copy data
      std::copy(source.data, source.data + source.size, data);
    }
    return *this;
  }

  // memory allocation
  void allocate(int size_) {

    deallocate();

    // new sizes
    size = size_;

    data = new double[size_];
    memset(data,0,size_*sizeof(double));

  } // allocate

  // memory free
  void deallocate() {

    if (data)
      delete[] data;

    data = nullptr;

  }

  //   ||x||
  double norm() {
    double sum = 0;
    for (int i = 0; i < size; i++) sum += (*this)(i) * (*this)(i);
    return sqrt(sum);
  }

  // divide data by factor
  void rescale(double factor) {
    for (int i = 0; i < size; i++) (*this)(i) /= factor;
  }

  void rescale_unit() {
    double factor = norm();
    rescale(factor);
  }

  int size;

private:
  double* data;

}; // class Vector

// c = a + b * s
void vmadd(const Vector& a, const Vector& b, double s, Vector& c)
{
  if (c.size != a.size or c.size != b.size) {
    std::cerr << "[vmadd]: vector sizes don't match\n";
    return;
  }

  for (int i = 0; i < c.size; i++)
    c(i) = a(i) + s * b(i);
}

// mat = I - 2*v*v^T
// !!! m is allocated here !!!
void compute_householder_factor(Matrix& mat, const Vector& v)
{

  int n = v.size;
  mat.allocate(n,n);
  for (int i = 0; i < n; i++)
    for (int j = 0; j < n; j++)
      mat(i,j) = -2 *  v(i) * v(j);
  for (int i = 0; i < n; i++)
    mat(i,i) += 1;
}

// take c-th column of a matrix, put results in Vector v
void Matrix::extract_column(Vector& v, int c) {
  if (m != v.size) {
    std::cerr << "[Matrix::extract_column]: Matrix and Vector sizes don't match\n";
    return;
  }

  for (int i = 0; i < m; i++)
    v(i) = (*this)(i,c);
}

void matrix_show(const Matrix&  m, const std::string& str="")
{
  std::cout << str << "\n";
  for(int i = 0; i < m.m; i++) {
    for (int j = 0; j < m.n; j++) {
      printf(" %8.3f", m(i,j));
    }
    printf("\n");
  }
  printf("\n");
}

// L2-norm ||A-B||^2
double matrix_compare(const Matrix& A, const Matrix& B) {
  // matrices must have same size
  if (A.m != B.m or  A.n != B.n)
    return std::numeric_limits<double>::max();

  double res=0;
  for(int i = 0; i < A.m; i++) {
    for (int j = 0; j < A.n; j++) {
      res += (A(i,j)-B(i,j)) * (A(i,j)-B(i,j));
    }
  }

  res /= A.m*A.n;
  return res;
}

void householder(Matrix& mat,
		 Matrix& R,
		 Matrix& Q)
{

  int m = mat.m;
  int n = mat.n;

  // array of factor Q1, Q2, ... Qm
  std::vector<Matrix> qv(m);

  // temp array
  Matrix z(mat);
  Matrix z1;

  for (int k = 0; k < n && k < m - 1; k++) {

    Vector e(m), x(m);
    double a;

    // compute minor
    z1.compute_minor(z, k);

    // extract k-th column into x
    z1.extract_column(x, k);

    a = x.norm();
    if (mat(k,k) > 0) a = -a;

    for (int i = 0; i < e.size; i++)
      e(i) = (i == k) ? 1 : 0;

    // e = x + a*e
    vmadd(x, e, a, e);

    // e = e / ||e||
    e.rescale_unit();

    // qv[k] = I - 2 *e*e^T
    compute_householder_factor(qv[k], e);

    // z = qv[k] * z1
    z.mult(qv[k], z1);

  }

  Q = qv[0];

  // after this loop, we will obtain Q (up to a transpose operation)
  for (int i = 1; i < n && i < m - 1; i++) {

    z1.mult(qv[i], Q);
    Q = z1;

  }

  R.mult(Q, mat);
  Q.transpose();
}

double in[][3] = {
  { 12, -51,   4},
  {  6, 167, -68},
  { -4,  24, -41},
  { -1,   1,   0},
  {  2,   0,   3},
};

int main()
{
  Matrix A(in);
  Matrix Q, R;

  matrix_show(A,"A");

  // compute QR decompostion
  householder(A, R, Q);

  matrix_show(Q,"Q");
  matrix_show(R,"R");

  // compare Q*R to the original matrix A
  Matrix A_check;
  A_check.mult(Q, R);

  // compute L2 norm ||A-A_check||^2
  double l2 = matrix_compare(A,A_check);

  // display Q*R
  matrix_show(A_check, l2 < 1e-12 ? "A == Q * R ? yes" : "A == Q * R ? no");

  return EXIT_SUCCESS;
}


empty(U-V) :-
    unify_with_occurs_check(U, V).

push(Queue, Value, NewQueue) :-
    append_dl(Queue, [Value|X]-X, NewQueue).

% when queue is empty pop fails.
pop([X|V]-U, X, V-U) :-
    \+empty([X|V]-U).

append_dl(X-Y, Y-Z, X-Z).


NewList MyStack()

Procedure Push(n)
  Shared MyStack()
  LastElement(MyStack())
  AddElement(MyStack())
  MyStack()=n
EndProcedure

Procedure Pop()
  Shared MyStack()
  Protected n
  If FirstElement(MyStack())  ; e.g. Stack not empty
    n=MyStack()
    DeleteElement(MyStack(),1)
  Else
    Debug "Pop(), out of range. Error at line "+str(#PB_Compiler_Line)
  EndIf
  ProcedureReturn n
EndProcedure

Procedure Empty()
  Shared MyStack()
  If  ListSize(MyStack())=0
    ProcedureReturn #True
  EndIf
  ProcedureReturn #False
EndProcedure

;----   Example of implementation ----
Push(3)
Push(1)
Push(4)
While Not Empty()
  Debug Pop()
Wend
;----   Now an extra Pop(), e.g. one to many ----
Debug Pop()


BEGIN
    # find values of d where d^2 =/= a^2 + b^2 + c^2 for any integers a, b, c #
    # where d in [1..2200], a, b, c =/= 0                                     #
    # max number to check #
    INT max number = 2200;
    INT max square = max number * max number;
    # table of numbers that can be the sum of two squares #
    [ 1 : max square ]BOOL sum of two squares; FOR n TO max square DO sum of two squares[ n ] := FALSE OD;
    FOR a TO max number DO
        INT a2 = a * a;
        FOR b FROM a TO max number WHILE INT sum2 = ( b * b ) + a2;
                                         sum2 <= max square DO
            sum of two squares[ sum2 ] := TRUE
        OD
    OD;
    # now find d such that d^2 - c^2 is in sum of two squares #
    [ 1 : max number ]BOOL solution; FOR n TO max number DO solution[ n ] := FALSE OD;
    FOR d TO max number DO
        INT d2 = d * d;
        FOR c TO d - 1 WHILE NOT solution[ d ] DO
            INT diff2 = d2 - ( c * c );
            IF sum of two squares[ diff2 ] THEN
                solution[ d ] := TRUE
            FI
        OD
    OD;
    # print the numbers whose squares are not the sum of three squares #
    FOR d TO max number DO
        IF NOT solution[ d ] THEN
            print( ( " ", whole( d, 0 ) ) )
        FI
    OD;
    print( ( newline ) )
END


#include <flow.h>

DEF-MAIN(argv, argc)
   SET(N, 2200)
   DIM( MUL(MUL(N,N),2) ) AS-ZEROS( temp )
   DIM( N ) AS-ZEROS( found )

   MSET( a,T1,T2 )
   TIC(T1)
   SEQ-SPC(1,N,N,a), LET( a := MUL(a,a) )

   SET(i,1), SET(r,0)
   PERF-UP(i,N,1)
       LET( r := ADD( [i] GET( a ), [i:end] CGET(a) ) )
       SET-RANGE( r ), SET(temp, 1), CLR-RANGE
   NEXT

   SET(c,1), SET(s,3), MSET(s1,s2,d)
   PERF-UP(c, N, 1)
       LET( s1 := s )
       s += 2
       LET( s2 := s )
       LET( d := ADD(c,1) )
       PERF-UP(d, N, 1)
           COND ( [s1] GET(temp) )
              [d] {1} PUT(found)
           CEND
           s1 += s2
           s2 += 2
       NEXT
   NEXT
   TOC(T1, T2), PRNL("Time = ", T2 )
   PRN( "Imprimiendo resultados:\n" )
   CART( IS-ZERO?( found ) ) MOVE-TO( r )
   PRNL( r )

   MCLEAR(temp, found, a, r)
END


-- double :: Num -> Num
on double(x)
    x + x
end double

-- powersOfTwo :: Generator [Int]
on powersOfTwo()
    iterate(double, 1)
end powersOfTwo

on run
    -- Two infinite lists, from each of which we can draw an arbitrary number of initial terms

    set xs to powersOfTwo() -- {1, 2, 4, 8, 16, 32 ...

    set ys to fmapGen(timesFive, powersOfTwo()) -- {5, 10, 20, 40, 80, 160 ...

    -- Another infinite list, derived from the first two (sorted in rising value)

    set zs to mergeInOrder(xs, ys) -- {1, 2, 4, 5, 8, 10 ...

    -- Taking terms from the derived list while their value is below 2200 ...

    takeWhileGen(le2200, zs)

    --> {1, 2, 4, 5, 8, 10, 16, 20, 32, 40, 64, 80, 128, 160, 256, 320, 512, 640, 1024, 1280, 2048}
end run

-- le2200 :: Num -> Bool
on le2200(x)
    x ≤ 2200
end le2200

-- timesFive :: Num -> Num
on timesFive(x)
    5 * x
end timesFive

-- mergeInOrder :: Generator [Int] -> Generator [Int] -> Generator [Int]
on mergeInOrder(ga, gb)
    script
        property a : uncons(ga)
        property b : uncons(gb)
        on |λ|()
            if (Nothing of a or Nothing of b) then
                missing value
            else
                set ta to Just of a
                set tb to Just of b
                if |1| of ta < |1| of tb then
                    set a to uncons(|2| of ta)
                    return |1| of ta
                else
                    set b to uncons(|2| of tb)
                    return |1| of tb
                end if
            end if
        end |λ|
    end script
end mergeInOrder

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

-- fmapGen <$> :: (a -> b) -> Gen [a] -> Gen [b]
on fmapGen(f, gen)
    script
        property g : gen
        property mf : mReturn(f)'s |λ|
        on |λ|()
            set v to g's |λ|()
            if v is missing value then
                v
            else
                mf(v)
            end if
        end |λ|
    end script
end fmapGen

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

-- Just :: a -> Maybe a
on Just(x)
    {type:"Maybe", Nothing:false, Just:x}
end Just

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

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

-- Nothing :: Maybe a
on Nothing()
    {type:"Maybe", Nothing:true}
end Nothing

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

-- takeWhileGen :: (a -> Bool) -> Gen [a] -> [a]
on takeWhileGen(p, xs)
    set ys to {}
    set v to |λ|() of xs
    tell mReturn(p)
        repeat while (|λ|(v))
            set end of ys to v
            set v to xs's |λ|()
        end repeat
    end tell
    return ys
end takeWhileGen

-- Tuple (,) :: a -> b -> (a, b)
on Tuple(a, b)
    {type:"Tuple", |1|:a, |2|:b, length:2}
end Tuple

-- uncons :: [a] -> Maybe (a, [a])
on uncons(xs)
    set lng to |length|(xs)
    if 0 = lng then
        Nothing()
    else
        if (2 ^ 29 - 1) as integer > lng then
            if class of xs is string then
                set cs to text items of xs
                Just(Tuple(item 1 of cs, rest of cs))
            else
                Just(Tuple(item 1 of xs, rest of xs))
            end if
        else
            Just(Tuple(item 1 of take(1, xs), xs))
        end if
    end if
end uncons


(defun sign (x)
  (if (zerop x)
      x
      (/ x (abs x))))

(defun norm (x)
  (let ((len (car (array-dimensions x))))
    (sqrt (loop for i from 0 to (1- len) sum (expt (aref x i 0) 2)))))

(defun make-unit-vector (dim)
  (let ((vec (make-array `(,dim ,1) :initial-element 0.0d0)))
    (setf (aref vec 0 0) 1.0d0)
    vec))

;; Return a nxn identity matrix.
(defun eye (n)
  (let ((I (make-array `(,n ,n) :initial-element 0)))
    (loop for j from 0 to (- n 1) do
          (setf (aref I j j) 1))
    I))

(defun array-range (A ma mb na nb)
  (let* ((mm (1+ (- mb ma)))
         (nn (1+ (- nb na)))
         (B (make-array `(,mm ,nn) :initial-element 0.0d0)))

    (loop for i from 0 to (1- mm) do
         (loop for j from 0 to (1- nn) do
              (setf (aref B i j)
                    (aref A (+ ma i) (+ na j)))))
    B))

(defun rows (A) (car  (array-dimensions A)))
(defun cols (A) (cadr (array-dimensions A)))
(defun mcol (A n) (array-range A 0 (1- (rows A)) n n))
(defun mrow (A n) (array-range A n n 0 (1- (cols A))))

(defun array-embed (A B row col)
  (let* ((ma (rows A))
         (na (cols A))
         (mb (rows B))
         (nb (cols B))
         (C  (make-array `(,ma ,na) :initial-element 0.0d0)))

    (loop for i from 0 to (1- ma) do
         (loop for j from 0 to (1- na) do
              (setf (aref C i j) (aref A i j))))

    (loop for i from 0 to (1- mb) do
         (loop for j from 0 to (1- nb) do
              (setf (aref C (+ row i) (+ col j))
                    (aref B i j))))

    C))


   class FIFO(object):
       def __init__(self, *args):
           self.contents = list(args)
       def __call__(self):
           return self.pop()
       def __len__(self):
           return len(self.contents)
       def pop(self):
           return self.contents.pop(0)
       def push(self, item):
           self.contents.append(item)
       def extend(self,*itemlist):
           self.contents += itemlist
       def empty(self):
           return bool(self.contents)
       def __iter__(self):
           return self
       def next(self):
           if self.empty():
               raise StopIteration
           return self.pop()

if __name__ == "__main__":
    # Sample usage:
    f = FIFO()
    f.push(3)
    f.push(2)
    f.push(1)
    while not f.empty():
        print f.pop(),
    # >>> 3 2 1
    # Another simple example gives the same results:
    f = FIFO(3,2,1)
    while not f.empty():
        print f(),
    # Another using the default "truth" value of the object
    # (implicitly calls on the length() of the object after
    # checking for a __nonzero__ method
    f = FIFO(3,2,1)
    while f:
        print f(),
    # Yet another, using more Pythonic iteration:
    f = FIFO(3,2,1)
    for i in f:
        print i,


# syntax: GAWK -f PYTHAGOREAN_QUADRUPLES.AWK
# converted from Go
BEGIN {
    n = 2200
    s = 3
    for (a=1; a<=n; a++) {
      a2 = a * a
      for (b=a; b<=n; b++) {
        ab[a2 + b * b] = 1
      }
    }
    for (c=1; c<=n; c++) {
      s1 = s
      s += 2
      s2 = s
      for (d=c+1; d<=n; d++) {
        if (ab[s1]) {
          r[d] = 1
        }
        s1 += s2
        s2 += 2
      }
    }
    for (d=1; d<=n; d++) {
      if (!r[d]) {
        printf("%d ",d)
      }
    }
    printf("\n")
    exit(0)
}


#include <stdio.h>
#include <math.h>
#include <string.h>

#define N 2200

int main(int argc, char **argv){
   int a,b,c,d;
   int r[N+1];
   memset(r,0,sizeof(r));	// zero solution array
   for(a=1; a<=N; a++){
      for(b=a; b<=N; b++){
	 int aabb;
	 if(a&1 && b&1) continue;  // for positive odd a and b, no solution.
	 aabb=a*a + b*b;
	 for(c=b; c<=N; c++){
	    int aabbcc=aabb + c*c;
	    d=(int)sqrt((float)aabbcc);
	    if(aabbcc == d*d && d<=N) r[d]=1;	// solution
	 }
      }
   }
   for(a=1; a<=N; a++)
      if(!r[a]) printf("%d ",a);	// print non solution
   printf("\n");
}


import std.stdio, std.math, std.algorithm, std.traits,
       std.typecons, std.numeric, std.range, std.conv;

template elementwiseMat(string op) {
    T[][] elementwiseMat(T)(in T[][] A, in T B) pure nothrow {
        if (A.empty)
            return null;
        auto R = new typeof(return)(A.length, A[0].length);
        foreach (immutable r, const row; A)
            R[r][] = mixin("row[] " ~ op ~ "B");
        return R;
    }

    T[][] elementwiseMat(T, U)(in T[][] A, in U[][] B)
    pure nothrow if (is(Unqual!T == Unqual!U)) {
        assert(A.length == B.length);
        if (A.empty)
            return null;
        auto R = new typeof(return)(A.length, A[0].length);
        foreach (immutable r, const row; A) {
            assert(row.length == B[r].length);
            R[r][] = mixin("row[] " ~ op ~ "B[r][]");
        }
        return R;
    }
}

alias mSum = elementwiseMat!q{ + },
      mSub = elementwiseMat!q{ - },
      pMul = elementwiseMat!q{ * },
      pDiv = elementwiseMat!q{ / };

bool isRectangular(T)(in T[][] mat) pure nothrow {
    return mat.all!(r => r.length == mat[0].length);
}

T[][] matMul(T)(in T[][] a, in T[][] b) pure nothrow
in {
    assert(a.isRectangular && b.isRectangular &&
           a[0].length == b.length);
} body {
    auto result = new T[][](a.length, b[0].length);
    auto aux = new T[b.length];
    foreach (immutable j; 0 .. b[0].length) {
        foreach (immutable k; 0 .. b.length)
            aux[k] = b[k][j];
        foreach (immutable i; 0 .. a.length)
            result[i][j] = a[i].dotProduct(aux);
    }
    return result;
}

Unqual!T[][] transpose(T)(in T[][] m) pure nothrow {
    auto r = new Unqual!T[][](m[0].length, m.length);
    foreach (immutable nr, row; m)
        foreach (immutable nc, immutable c; row)
            r[nc][nr] = c;
    return r;
}

T norm(T)(in T[][] m) pure nothrow {
    return transversal(m, 0).map!q{ a ^^ 2 }.sum.sqrt;
}

Unqual!T[][] makeUnitVector(T)(in size_t dim) pure nothrow {
    auto result = new Unqual!T[][](dim, 1);
    foreach (row; result)
        row[] = 0;
    result[0][0] = 1;
    return result;
}

/// Return a nxn identity matrix.
Unqual!T[][] matId(T)(in size_t n) pure nothrow {
    auto Id = new Unqual!T[][](n, n);
    foreach (immutable r, row; Id) {
        row[] = 0;
        row[r] = 1;
    }
    return Id;
}

T[][] slice2D(T)(in T[][] A,
                 in size_t ma, in size_t mb,
                 in size_t na, in size_t nb) pure nothrow {
    auto B = new T[][](mb - ma + 1, nb - na + 1);
    foreach (immutable i, brow; B)
        brow[] = A[ma + i][na .. na + brow.length];
    return B;
}

size_t rows(T)(in T[][] A) pure nothrow { return A.length; }

size_t cols(T)(in T[][] A) pure nothrow {
    return A.length ? A[0].length : 0;
}

T[][] mcol(T)(in T[][] A, in size_t n) pure nothrow {
    return slice2D(A, 0, A.rows - 1, n, n);
}

T[][] matEmbed(T)(in T[][] A, in T[][] B,
                  in size_t row, in size_t col) pure nothrow {
    auto C = new T[][](rows(A), cols(A));
    foreach (immutable i, const arow; A)
        C[i][] = arow[]; // Some wasted copies.
    foreach (immutable i, const brow; B)
        C[row + i][col .. col + brow.length] = brow[];
    return C;
}

// Main routines ---------------

T[][] makeHouseholder(T)(in T[][] a) {
    immutable m = a.rows;
    immutable T s = a[0][0].sgn;
    immutable e = makeUnitVector!T(m);
    immutable u = mSum(a, pMul(e, a.norm * s));
    immutable v = pDiv(u, u[0][0]);
    immutable beta = 2.0 / v.transpose.matMul(v)[0][0];
    return mSub(matId!T(m), pMul(v.matMul(v.transpose), beta));
}

Tuple!(T[][],"Q", T[][],"R") QRdecomposition(T)(T[][] A) {
    immutable m = A.rows;
    immutable n = A.cols;
    auto Q = matId!T(m);

    // Work on n columns of A.
    foreach (immutable i; 0 .. (m == n ? n - 1 : n)) {
        // Select the i-th submatrix. For i=0 this means the original
        // matrix A.
        immutable B = slice2D(A, i, m - 1, i, n - 1);

        // Take the first column of the current submatrix B.
        immutable x = mcol(B, 0);

        // Create the Householder matrix for the column and embed it
        // into an mxm identity.
        immutable H = matEmbed(matId!T(m), x.makeHouseholder, i, i);

        // The product of all H matrices from the right hand side is
        // the orthogonal matrix Q.
        Q = Q.matMul(H);

        // The product of all H matrices with A from the LHS is the
        // upper triangular matrix R.
        A  = H.matMul(A);
    }

    // Return Q and R.
    return typeof(return)(Q, A);
}

// Polynomial regression ---------------

/// Solve an upper triangular system by back substitution.
T[][] solveUpperTriangular(T)(in T[][] R, in T[][] b) pure nothrow {
    immutable n = R.cols;
    auto x = new T[][](n, 1);

    foreach_reverse (immutable k; 0 .. n) {
        T tot = 0;
        foreach (immutable j; k + 1 .. n)
            tot += R[k][j] * x[j][0];
        x[k][0] = (b[k][0] - tot) / R[k][k];
    }

    return x;
}

/// Solve a linear least squares problem by QR decomposition.
T[][] lsqr(T)(T[][] A, in T[][] b) pure nothrow {
    const qr = A.QRdecomposition;
    immutable n = qr.R.cols;
    return solveUpperTriangular(
        slice2D(qr.R, 0, n - 1, 0, n - 1),
        slice2D(qr.Q.transpose.matMul(b), 0, n - 1, 0, 0));
}

T[][] polyFit(T)(in T[][] x, in T[][] y, in size_t n) pure nothrow {
    immutable size_t m = x.cols;
    auto A = new T[][](m, n + 1);
    foreach (immutable i, row; A)
        foreach (immutable j, ref item; row)
            item = x[0][i] ^^ j;
    return lsqr(A, y.transpose);
}

void main() {
    // immutable (Q, R) = QRdecomposition([[12.0, -51,   4],
    immutable qr = QRdecomposition([[12.0, -51,   4],
                                    [ 6.0, 167, -68],
                                    [-4.0,  24, -41]]);
    immutable form = "[%([%(%2.3f, %)]%|,\n %)]\n";
    writefln(form, qr.Q);
    writefln(form, qr.R);

    immutable x = [[0.0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]];
    immutable y = [[1.0, 6, 17, 34, 57, 86, 121, 162, 209, 262, 321]];
    polyFit(x, y, 2).writeln;
}


  [ [] ]                              is queue  (     --> [   )

  [ [] = ]                            is empty? (   [ --> b   )

  [ nested join ]                     is push   ( [ x --> [   )

  [ dup empty? if
      [ $ "Queue unexpectedly empty."
        fail ]
    behead ]                          is pop    (   [ --> [ x )


using System;

namespace PythagoreanQuadruples {
    class Program {
        const int MAX = 2200;
        const int MAX2 = MAX * MAX * 2;

        static void Main(string[] args) {
            bool[] found = new bool[MAX + 1]; // all false by default
            bool[] a2b2 = new bool[MAX2 + 1]; // ditto
            int s = 3;

            for(int a = 1; a <= MAX; a++) {
                int a2 = a * a;
                for (int b=a; b<=MAX; b++) {
                    a2b2[a2 + b * b] = true;
                }
            }

            for (int c = 1; c <= MAX; c++) {
                int s1 = s;
                s += 2;
                int s2 = s;
                for (int d = c + 1; d <= MAX; d++) {
                    if (a2b2[s1]) found[d] = true;
                    s1 += s2;
                    s2 += 2;
                }
            }

            Console.WriteLine("The values of d <= {0} which can't be represented:", MAX);
            for (int d = 1; d < MAX; d++) {
                if (!found[d]) Console.Write("{0}  ", d);
            }
            Console.WriteLine();
        }
    }
}


#include <iostream>
#include <vector>

constexpr int N = 2200;
constexpr int N2 = 2 * N * N;

int main() {
    using namespace std;

    vector<bool> found(N + 1);
    vector<bool> aabb(N2 + 1);

    int s = 3;

    for (int a = 1; a < N; ++a) {
        int aa = a * a;
        for (int b = 1; b < N; ++b) {
            aabb[aa + b * b] = true;
        }
    }

    for (int c = 1; c <= N; ++c) {
        int s1 = s;
        s += 2;
        int s2 = s;
        for (int d = c + 1; d <= N; ++d) {
            if (aabb[s1]) {
                found[d] = true;
            }
            s1 += s2;
            s2 += 2;
        }
    }

    cout << "The values of d <= " << N << " which can't be represented:" << endl;
    for (int d = 1; d <= N; ++d) {
        if (!found[d]) {
            cout << d << " ";
        }
    }
    cout << endl;

    return 0;
}


// QR decomposition. Nigel Galloway: January 11th., 2022
let n=[[12.0;-51.0;4.0];[6.0;167.0;-68.0];[-4.0;24.0;-41.0]]|>MathNet.Numerics.LinearAlgebra.MatrixExtensions.matrix
let g=n|>MathNet.Numerics.LinearAlgebra.Matrix.qr
printfn $"Matrix\n------\n%A{n}\nQ\n-\n%A{g.Q}\nR\n-\n%A{g.R}"