program qrtask
    implicit none
    integer, parameter :: n = 4
    real(8) :: durer(n, n) = reshape(dble([ &
        16,  5,  9,  4, &
         3, 10,  6, 15, &
         2, 11,  7, 14, &
        13,  8, 12,  1  &
    ]), [n, n])
    real(8) :: q(n, n), r(n, n), qr(n, n), id(n, n), tau(n)
    integer, parameter :: lwork = 1024
    real(8) :: work(lwork)
    integer :: info, i, j

    q = durer
    call dgeqrf(n, n, q, n, tau, work, lwork, info)

    r = 0d0
    forall (i = 1:n, j = 1:n, j >= i) r(i, j) = q(i, j)

    call dorgqr(n, n, n, q, n, tau, work, lwork, info)

    qr = matmul(q, r)
    id = matmul(q, transpose(q))

    call show(4, durer, "A")
    call show(4, q, "Q")
    call show(4, r, "R")
    call show(4, qr, "Q*R")
    call show(4, id, "Q*Q'")
contains
    subroutine show(n, a, s)
        character(*) :: s
        integer :: n, i
        real(8) :: a(n, n)

        print *, s
        do i = 1, n
            print 1, a(i, :)
          1 format (*(f12.6,:,' '))
        end do
    end subroutine
end program


#lang racket

(define (make-queue) (mcons #f #f))
(define (push! q x)
  (define new (mcons x #f))
  (if (mcar q) (set-mcdr! (mcdr q) new) (set-mcar! q new))
  (set-mcdr! q new))
(define (pop! q)
  (define old (mcar q))
  (cond [(eq? old (mcdr q)) (set-mcar! q #f) (set-mcdr! q #f)]
        [else (set-mcar! q (mcdr old))])
  (mcar old))
(define (empty? q)
  (not (mcar q)))

(define Q (make-queue))
(empty? Q) ; -> #t
(push! Q 'x)
(empty? Q) ; -> #f
(for ([x 3]) (push! Q x))
(pop! Q)   ; -> 'x
(list (pop! Q) (pop! Q) (pop! Q)) ; -> '(0 1 2)


role FIFO {
    method enqueue ( *@values ) { # Add values to queue, returns the number of values added.
        self.push: @values;
        return @values.elems;
    }
    method dequeue ( ) {         # Remove and return the first value from the queue.
                                 # Return Nil if queue is empty.
        return self.elems ?? self.shift !! Nil;
    }
    method is-empty ( ) {        # Check to see if queue is empty. Returns Boolean value.
        return self.elems == 0;
    }
}

# Example usage:

my @queue does FIFO;

say @queue.is-empty;                         # -> Bool::True
for <A B C> -> $i { say @queue.enqueue: $i } # 1 \n 1 \n 1
say @queue.enqueue: Any;                     # -> 1
say @queue.enqueue: 7, 8;                    # -> 2
say @queue.is-empty;                         # -> Bool::False
say @queue.dequeue;                          # -> A
say @queue.elems;                            # -> 4
say @queue.dequeue;                          # -> B
say @queue.is-empty;                         # -> Bool::False
say @queue.enqueue('OHAI!');                 # -> 1
say @queue.dequeue until @queue.is-empty;    # -> C \n Any() \n [7 8] \n OHAI!
say @queue.is-empty;                         # -> Bool::True
say @queue.dequeue;                          # ->


n = 2200
l_add, l = Hash(Int32, Bool).new(false), Hash(Int32, Bool).new(false)
(1..n).each do |x|
  x2 = x * x
  (x..n).each { |y| l_add[x2 + y * y] = true }
end

s = 3
(1..n).each do |x|
  s1 = s
  s += 2
  s2 = s
  ((x+1)..n).each do |y|
    l[y] = true if l_add[s1]
    s1 += s2
    s2 += 2
  end
end

puts (1..n).reject{ |x| l[x] }.join(" ")


import std.bitmanip : BitArray;
import std.stdio;

enum N = 2_200;
enum N2 = 2*N*N;

void main() {
    BitArray found;
    found.length = N+1;

    BitArray aabb;
    aabb.length = N2+1;

    uint s=3;

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

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

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


import "lib/github.com/diku-dk/linalg/linalg"

module linalg_f64 = mk_linalg f64

let eye (n: i32): [n][n]f64 =
  let arr = map (\ind -> let (i,j) = (ind/n,ind%n) in if (i==j) then 1.0 else 0.0) (iota (n*n))
  in unflatten n n arr

let norm v = linalg_f64.dotprod v v |> f64.sqrt

let qr [n] [m] (a: [m][n]f64): ([m][m]f64, [m][n]f64) =

  let make_householder [d] (x: [d]f64): [d][d]f64 =
    let div = if x[0] > 0 then x[0] + norm x else x[0] - norm x
    let v = map (/div) x
    let v[0] = 1
    let fac = 2.0 / linalg_f64.dotprod v v
    in map2 (map2 (-)) (eye d) (map (map (*fac)) (linalg_f64.outer v v))

  let step ((x,y):([m][m]f64,[m][n]f64)) (i:i32): ([m][m]f64,[m][n]f64) =
    let h = eye m
    let h[i:m,i:m] = make_householder y[i:m,i]
    let q': [m][m]f64 = linalg_f64.matmul x h
    let a': [m][n]f64 = linalg_f64.matmul h y
    in (q',a')

  let q = eye m
  in foldl step (q,a) (iota n)

entry main = qr [[12.0, -51.0, 4.0],[6.0, 167.0, -68.0],[-4.0, 24.0, -41.0]]


package main

import (
    "fmt"
    "math"

    "github.com/skelterjohn/go.matrix"
)

func sign(s float64) float64 {
    if s > 0 {
        return 1
    } else if s < 0 {
        return -1
    }
    return 0
}

func unitVector(n int) *matrix.DenseMatrix {
    vec := matrix.Zeros(n, 1)
    vec.Set(0, 0, 1)
    return vec
}

func householder(a *matrix.DenseMatrix) *matrix.DenseMatrix {
    m := a.Rows()
    s := sign(a.Get(0, 0))
    e := unitVector(m)
    u := matrix.Sum(a, matrix.Scaled(e, a.TwoNorm()*s))
    v := matrix.Scaled(u, 1/u.Get(0, 0))
    // (error checking skipped in this solution)
    prod, _ := v.Transpose().TimesDense(v)
    β := 2 / prod.Get(0, 0)

    prod, _ = v.TimesDense(v.Transpose())
    return matrix.Difference(matrix.Eye(m), matrix.Scaled(prod, β))
}

func qr(a *matrix.DenseMatrix) (q, r *matrix.DenseMatrix) {
    m := a.Rows()
    n := a.Cols()
    q = matrix.Eye(m)

    last := n - 1
    if m == n {
        last--
    }
    for i := 0; i <= last; i++ {
        // (copy is only for compatibility with an older version of gomatrix)
        b := a.GetMatrix(i, i, m-i, n-i).Copy()
        x := b.GetColVector(0)
        h := matrix.Eye(m)
        h.SetMatrix(i, i, householder(x))
        q, _ = q.TimesDense(h)
        a, _ = h.TimesDense(a)
    }
    return q, a
}

func main() {
    // task 1: show qr decomp of wp example
    a := matrix.MakeDenseMatrixStacked([][]float64{
        {12, -51, 4},
        {6, 167, -68},
        {-4, 24, -41}})
    q, r := qr(a)
    fmt.Println("q:\n", q)
    fmt.Println("r:\n", r)

    // task 2: use qr decomp for polynomial regression example
    x := matrix.MakeDenseMatrixStacked([][]float64{
        {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10}})
    y := matrix.MakeDenseMatrixStacked([][]float64{
        {1, 6, 17, 34, 57, 86, 121, 162, 209, 262, 321}})
    fmt.Println("\npolyfit:\n", polyfit(x, y, 2))
}

func polyfit(x, y *matrix.DenseMatrix, n int) *matrix.DenseMatrix {
    m := x.Cols()
    a := matrix.Zeros(m, n+1)
    for i := 0; i < m; i++ {
        for j := 0; j <= n; j++ {
            a.Set(i, j, math.Pow(x.Get(0, i), float64(j)))
        }
    }
    return lsqr(a, y.Transpose())
}

func lsqr(a, b *matrix.DenseMatrix) *matrix.DenseMatrix {
    q, r := qr(a)
    n := r.Cols()
    prod, _ := q.Transpose().TimesDense(b)
    return solveUT(r.GetMatrix(0, 0, n, n), prod.GetMatrix(0, 0, n, 1))
}

func solveUT(r, b *matrix.DenseMatrix) *matrix.DenseMatrix {
    n := r.Cols()
    x := matrix.Zeros(n, 1)
    for k := n - 1; k >= 0; k-- {
        sum := 0.
        for j := k + 1; j < n; j++ {
            sum += r.Get(k, j) * x.Get(j, 0)
        }
        x.Set(k, 0, (b.Get(k, 0)-sum)/r.Get(k, k))
    }
    return x
}


rebol [
    Title: "FIFO"
    URL: http://rosettacode.org/wiki/FIFO
]

; Define fifo class:

fifo: make object! [
    queue: copy []
    push:  func [x][append queue x]
    pop:   func [/local x][   ; Make 'x' local so it won't pollute global namespace.
        if empty [return none]
        x: first queue  remove queue  x]
    empty: does [empty? queue]
]

; Create and populate a FIFO:

q: make fifo []
q/push 'a
q/push 2
q/push USD$12.34              ; Did I mention that REBOL has 'money!' datatype?
q/push [Athos Porthos Aramis] ; List elements pushed on one by one.
q/push [[Huey Dewey Lewey]]   ; This list is preserved as a list.

; Dump it out, with narrative:

print rejoin ["Queue is "  either q/empty [""]["not "]  "empty."]
while [not q/empty][print ["  " q/pop]]
print rejoin ["Queue is "  either q/empty [""]["not "]  "empty."]
print ["Trying to pop an empty queue yields:" q/pop]


/*REXX program to demonstrate FIFO queue usage by some simple operations*/
call viewQueue
a="Fred"
push                                   /*puts a  "null" on top of queue.*/
push a 2                               /*puts  "Fred 2" on top of queue.*/
call viewQueue

queue "Toft 2"                         /*put  "Toft 2"  on queue bottom.*/
queue                                  /*put a "null"   on queue bottom.*/
call viewQueue
                  do n=1  while queued()\==0
                  parse pull xxx
                  say "queue entry" n': ' xxx
                  end   /*n*/
call viewQueue
exit                                   /*stick a fork in it, we're done.*/
/*──────────────────────────────────viewQueue subroutine────────────────*/
viewQueue:  if queued()==0 then say 'Queue is empty'
                           else say 'There are' queued() 'elements in the queue'
return


' version 12-08-2017
' compile with: fbc -s console

#Define max 2200

Dim As UInteger l, m, n, l2, l2m2
Dim As UInteger limit = max * 4 \ 15
Dim As UInteger max2 = limit * limit * 2
ReDim As Ubyte list_1(max2), list_2(max2 +1)

' prime sieve, list_2(l) contains a 0 if l = prime
For l = 4 To max2 Step 2
    list_1(l) = 1
Next
For l = 3 To max2 Step 2
    If list_1(l) = 0 Then
        For m = l * l To max2 Step l * 2
            list_1(m) = 1
        Next
    End If
Next

' we do not need a and b (a and b are even, l = a \ 2, m = b \ 2)
' we only need to find d
For l = 1 To limit
    l2 = l * l
    For m = l To limit
        l2m2 = l2 + m * m
        list_2(l2m2 +1) = 1
        ' if l2m2 is a prime, no other factors exits
        If list_1(l2m2) = 0 Then Continue For
        ' find possible factors of l2m2
        ' if l2m2 is odd, we need only to check the odd divisors
        For n = 2 + (l2m2 And 1) To Fix(Sqr(l2m2 -1)) Step 1 + (l2m2 And 1)
            If l2m2 Mod n = 0 Then
                ' set list_2(x) to 1 if solution is found
                list_2(l2m2 \ n + n) = 1
            End If
        Next
    Next
Next

For l = 1 To max
    If list_2(l) = 0 Then Print l; " ";
Next
Print

' empty keyboard buffer
While InKey <> "" : Wend
Print : Print "hit any key to end program"
Sleep
End


package main

import "fmt"

const (
    N = 2200
    N2 = N * N * 2
)

func main() {
    s  := 3
    var s1, s2 int
    var r  [N + 1]bool
    var ab [N2 + 1]bool

    for a := 1; a <= N; a++ {
        a2 := a * a
        for b := a; b <= N; b++ {
            ab[a2 + b * b] = true
        }
    }

    for c := 1; c <= N; c++ {
        s1 = s
        s += 2
        s2 = s
        for d := c + 1; d <= N; d++ {
            if ab[s1] {
                r[d] = true
            }
            s1 += s2
            s2 += 2
        }
    }

    for d := 1; d <= N; d++ {
        if !r[d] {
            fmt.Printf("%d ", d)
        }
    }
    fmt.Println()
}


import Data.List
import Text.Printf (printf)

eps = 1e-6 :: Double

-- a matrix is represented as a list of columns
mmult :: Num a => [[a]] -> [[a]] -> [[a]]
nth :: Num a => [[a]] -> Int -> Int -> a
mmult_num :: Num a => [[a]] -> a -> [[a]]
madd :: Num a => [[a]] -> [[a]] -> [[a]]
idMatrix :: Num a => Int -> Int -> [[a]]

adjustWithE :: [[Double]] -> Int -> [[Double]]

mmult a b = [ [ sum $ zipWith (*) ak bj | ak <- (transpose a) ] | bj <- b ]
nth mA i j = (mA !! j) !! i
mmult_num mA n = map (\c -> map (*n) c) mA
madd mA mB = zipWith (\c1 c2 -> zipWith (+) c1 c2) mA mB
idMatrix n m = [ [if (i==j) then 1 else 0 | i <- [1..n]] | j <- [1..m]]

adjustWithE mA n = let lA = length mA in
    (idMatrix n (n - lA)) ++ (map (\c -> (take (n - lA) (repeat 0.0)) ++ c ) mA)

-- auxiliary functions
sqsum :: Floating a => [a] -> a
norm :: Floating a => [a] -> a
epsilonize :: [[Double]] -> [[Double]]

sqsum a = foldl (\x y -> x + y*y) 0 a
norm a = sqrt $! sqsum a
epsilonize mA = map (\c -> map (\x -> if abs x <= eps then 0 else x) c) mA

-- Householder transformation; householder A = (Q, R)
uTransform :: [Double] -> [Double]
hMatrix :: [Double] -> Int -> Int -> [[Double]]
householder :: [[Double]] -> ([[Double]], [[Double]])

-- householder_rec Q R A
householder_rec :: [[Double]] -> [[Double]] -> Int -> ([[Double]], [[Double]])

uTransform a = let t = (head a) + (signum (head a))*(norm a) in
    1 : map (\x -> x/t) (tail a)

hMatrix a n i = let u = uTransform (drop i a) in
    madd
        (idMatrix (n-i) (n-i))
        (mmult_num
            (mmult [u] (transpose [u]))
            ((/) (-2) (sqsum u)))

householder_rec mQ mR 0 = (mQ, mR)
householder_rec mQ mR n = let mSize = length mR in
    let mH = adjustWithE (hMatrix (mR!!(mSize - n)) mSize (mSize - n)) mSize in
        householder_rec (mmult mQ mH) (mmult mH mR) (n - 1)

householder mA = let mSize = length mA in
    let (mQ, mR) = householder_rec (idMatrix mSize mSize) mA mSize in
        (epsilonize mQ, epsilonize mR)

backSubstitution :: [[Double]] -> [Double] -> [Double] -> [Double]
backSubstitution mR [] res = res
backSubstitution mR@(hR:tR) q@(h:t) res =
    let x = (h / (head hR)) in
        backSubstitution
            (map tail tR)
            (tail (zipWith (-) q (map (*x) hR)))
            (x : res)

showMatrix :: [[Double]] -> String
showMatrix mA =
    concat $ intersperse "\n"
        (map (\x -> unwords $ printf "%10.4f" <$> (x::[Double])) (transpose mA))

mY = [[12, 6, -4], [-51, 167, 24], [4, -68, -41]] :: [[Double]]
q = [21, 245, 35] :: [Double]
main = let (mQ, mR) = householder mY in
    putStrLn ("Q: \n" ++ showMatrix mQ) >>
    putStrLn ("R: \n" ++ showMatrix mR) >>
    putStrLn ("q: \n" ++ show q) >>
    putStrLn ("x: \n" ++ show (backSubstitution (reverse (map reverse mR)) (reverse q) []))


# Project : Queue/Definition

load "stdlib.ring"
oQueue = new Queue
for n = 5 to 7
     see "Push: " + n + nl
     oQueue.add(n)
next
see "Pop: " + oQueue.remove() + nl
see "Push: 8" + nl
oQueue.add(8)
see "Pop: " + oQueue.remove() + nl
see "Pop: " + oQueue.remove() + nl
see "Pop: " + oQueue.remove() + nl
if len(oQueue) != 0
   oQueue.print()
else
   see "Error: queue is empty" + nl
ok


require 'forwardable'

# A FIFO queue contains elements in first-in, first-out order.
# FIFO#push adds new elements to the end of the queue;
# FIFO#pop or FIFO#shift removes elements from the front.
class FIFO
  extend Forwardable

  # Creates a FIFO containing _objects_.
  def self.[](*objects)
    new.push(*objects)
  end

  # Creates an empty FIFO.
  def initialize; @ary = []; end

  # Appends _objects_ to the end of this FIFO. Returns self.
  def push(*objects)
    @ary.push(*objects)
    self
  end
  alias << push
  alias enqueue push

  ##
  # :method: pop
  # :call-seq:
  #   pop -> obj or nil
  #   pop(n) -> ary
  #
  # Removes an element from the front of this FIFO, and returns it.
  # Returns nil if the FIFO is empty.
  #
  # If passing a number _n_, removes the first _n_ elements, and returns
  # an Array of them. If this FIFO contains fewer than _n_ elements,
  # returns them all. If this FIFO is empty, returns an empty Array.
  def_delegator :@ary, :shift, :pop
  alias shift pop
  alias dequeue shift

  ##
  # :method: empty?
  # Returns true if this FIFO contains no elements.
  def_delegator :@ary, :empty?

  ##
  # :method: size
  # Returns the number of elements in this FIFO.
  def_delegator :@ary, :size
  alias length size

  # Converts this FIFO to a String.
  def to_s
    "FIFO#{@ary.inspect}"
  end
  alias inspect to_s
end


powersOfTwo :: [Int]
powersOfTwo = iterate (2 *) 1

unrepresentable :: [Int]
unrepresentable = merge powersOfTwo ((5 *) <$> powersOfTwo)

merge :: [Int] -> [Int] -> [Int]
merge xxs@(x:xs) yys@(y:ys)
  | x < y = x : merge xs yys
  | otherwise = y : merge xxs ys

main :: IO ()
main = do
  putStrLn "The values of d <= 2200 which can't be represented."
  print $ takeWhile (<= 2200) unrepresentable


   Filter =: (#~`)(`:6)

   B =: *: A =: i. >: i. 2200

   S1 =: , B +/ B             NB. S1 is a raveled table of the sums of squares
   S1 =: <:&({:B)Filter S1    NB. remove sums of squares exceeding bound
   S1 =: ~. S1                NB. remove duplicate entries

   S2 =: , B +/ S1
   S2 =: <:&({:B)Filter S2
   S2 =: ~. S2

   RESULT =: (B [email protected]:e. S2) # A
   RESULT
1 2 4 5 8 10 16 20 32 40 64 80 128 160 256 320 512 640 1024 1280 2048


import java.util.ArrayList;
import java.util.List;

public class PythagoreanQuadruples {

    public static void main(String[] args) {
        long d = 2200;
        System.out.printf("Values of d < %d where a, b, and c are non-zero and a^2 + b^2 + c^2 = d^2 has no solutions:%n%s%n", d, getPythagoreanQuadruples(d));
    }

    //  See:  https://oeis.org/A094958
    private static List<Long> getPythagoreanQuadruples(long max) {
        List<Long> list = new ArrayList<>();
        long n = -1;
        long m = -1;
        while ( true ) {
            long nTest = (long) Math.pow(2, n+1);
            long mTest = (long) (5L * Math.pow(2, m+1));
            long test = 0;
            if ( nTest > mTest ) {
                test = mTest;
                m++;
            }
            else {
                test = nTest;
                n++;
            }
            if ( test < max ) {
                list.add(test);
            }
            else {
                break;
            }
        }
        return list;
    }

}


import Jama.Matrix;
import Jama.QRDecomposition;

public class Decompose {
    public static void main(String[] args) {
        var matrix = new Matrix(new double[][] {
            {12, -51,   4},
            { 6, 167, -68},
            {-4,  24, -41},
        });

        var qr = new QRDecomposition(matrix);
        qr.getQ().print(10, 4);
        qr.getR().print(10, 4);
    }
}


use std::collections::VecDeque;
fn main() {
    let mut stack = VecDeque::new();
    stack.push_back("Element1");
    stack.push_back("Element2");
    stack.push_back("Element3");

    assert_eq!(Some(&"Element1"), stack.front());
    assert_eq!(Some("Element1"), stack.pop_front());
    assert_eq!(Some("Element2"), stack.pop_front());
    assert_eq!(Some("Element3"), stack.pop_front());
    assert_eq!(None, stack.pop_front());
}


class Queue[T] {
  private[this] class Node[T](val value:T) {
    var next:Option[Node[T]]=None
    def append(n:Node[T])=next=Some(n)
  }
  private[this] var head:Option[Node[T]]=None
  private[this] var tail:Option[Node[T]]=None

  def isEmpty=head.isEmpty

  def enqueue(item:T)={
    val n=new Node(item)
    if(isEmpty) head=Some(n) else tail.get.append(n)
    tail=Some(n)
  }

  def dequeue:T=head match {
    case Some(item) => head=item.next; item.value
    case None => throw new java.util.NoSuchElementException()
  }

  def front:T=head match {
    case Some(item) => item.value
    case None => throw new java.util.NoSuchElementException()
  }

  def iterator: Iterator[T]=new Iterator[T]{
    private[this] var it=head;
    override def hasNext=it.isDefined
    override def next:T={val n=it.get; it=n.next; n.value}
  }

  override def toString()=iterator.mkString("Queue(", ", ", ")")
}


(() => {
    'use strict';

    // main :: IO ()
    const main = () => {
        const xs = takeWhileGen(
            x => 2200 >= x,
            mergeInOrder(
                powersOfTwo(),
                fmapGen(x => 5 * x, powersOfTwo())
            )
        );

        return (
            console.log(JSON.stringify(xs)),
            xs
        );
    }

    // powersOfTwo :: Gen [Int]
    const powersOfTwo = () =>
        iterate(x => 2 * x, 1);

    // mergeInOrder :: Gen [Int] -> Gen [Int] -> Gen [Int]
    const mergeInOrder = (ga, gb) => {
        function* go(ma, mb) {
            let
                a = ma,
                b = mb;
            while (!a.Nothing && !b.Nothing) {
                let
                    ta = a.Just,
                    tb = b.Just;
                if (fst(ta) < fst(tb)) {
                    yield(fst(ta));
                    a = uncons(snd(ta))
                } else {
                    yield(fst(tb));
                    b = uncons(snd(tb))
                }
            }
        }
        return go(uncons(ga), uncons(gb))
    };

    // GENERIC FUNCTIONS ----------------------------

    // fmapGen <$> :: (a -> b) -> Gen [a] -> Gen [b]
    function* fmapGen(f, gen) {
        const g = gen;
        let v = take(1, g);
        while (0 < v.length) {
            yield(f(v))
            v = take(1, g)
        }
    }

    // fst :: (a, b) -> a
    const fst = tpl => tpl[0];

    // iterate :: (a -> a) -> a -> Generator [a]
    function* iterate(f, x) {
        let v = x;
        while (true) {
            yield(v);
            v = f(v);
        }
    }

    // Just :: a -> Maybe a
    const Just = x => ({
        type: 'Maybe',
        Nothing: false,
        Just: x
    });

    // Returns Infinity over objects without finite length
    // this enables zip and zipWith to choose the shorter
    // argument when one is non-finite, like cycle, repeat etc

    // length :: [a] -> Int
    const length = xs => xs.length || Infinity;

    // Nothing :: Maybe a
    const Nothing = () => ({
        type: 'Maybe',
        Nothing: true,
    });

    // snd :: (a, b) -> b
    const snd = tpl => tpl[1];

    // take :: Int -> [a] -> [a]
    // take :: Int -> String -> String
    const take = (n, xs) =>
        xs.constructor.constructor.name !== 'GeneratorFunction' ? (
            xs.slice(0, n)
        ) : [].concat.apply([], Array.from({
            length: n
        }, () => {
            const x = xs.next();
            return x.done ? [] : [x.value];
        }));

    // takeWhileGen :: (a -> Bool) -> Generator [a] -> [a]
    const takeWhileGen = (p, xs) => {
        const ys = [];
        let
            nxt = xs.next(),
            v = nxt.value;
        while (!nxt.done && p(v)) {
            ys.push(v);
            nxt = xs.next();
            v = nxt.value
        }
        return ys;
    };

    // Tuple (,) :: a -> b -> (a, b)
    const Tuple = (a, b) => ({
        type: 'Tuple',
        '0': a,
        '1': b,
        length: 2
    });

    // uncons :: [a] -> Maybe (a, [a])
    const uncons = xs => {
        const lng = length(xs);
        return (0 < lng) ? (
            lng < Infinity ? (
                Just(Tuple(xs[0], xs.slice(1))) // Finite list
            ) : (() => {
                const nxt = take(1, xs);
                return 0 < nxt.length ? (
                    Just(Tuple(nxt[0], xs))
                ) : Nothing();
            })() // Lazy generator
        ) : Nothing();
    };

    // MAIN ---
    return main();
})();


(define (make-queue)
  (make-vector 1 '()))

(define (push a queue)
  (vector-set! queue 0 (append (vector-ref queue 0) (list a))))

(define (empty? queue)
  (null? (vector-ref queue 0)))

(define (pop queue)
  (if (empty? queue)
      (error "can not pop an empty queue")
      (let ((ret (car (vector-ref queue 0))))
        (vector-set! queue 0 (cdr (vector-ref queue 0)))
        ret)))


set myFoods to be an empty list

push "grapes" into myFoods
push "orange" into myFoods
push "apricot" into myFoods

put "The foods in my queue are: " & myFoods

pull from myFoods into firstThingToEat

put "The first thing to eat is: " & firstThingToEat

if myFoods is empty then
    put "The foods list is empty!"
else
    put "The remaining foods are: " & myFoods
end if


# Emit a proof that the input is a pythagorean quad, or else false
def is_pythagorean_quad:
  . as $d
  | (.*.) as $d2
  | first(
      label $continue_a | range(1; $d) | . as $a | (.*.) as $a2
    |   if 3*$a2 > $d2 then break $continue_a else . end
    | label $continue_b | range($a; $d) | . as $b | (.*.) as $b2
    |   if $a2  + 2 * $b2  > $d2 then break $continue_b else . end
    | (($d2-($a2+$b2)) | sqrt) as $c
    | if ($c | floor) == $c then [$a, $b, $c] else empty end )
  // false;

# The specific task:

[range(1; 2201) | select( is_pythagorean_quad | not )] | join(" ")


function quadruples(N::Int=2200)
    r  = falses(N)
    ab = falses(2N ^ 2)

    for a in 1:N, b in a:N
        ab[a ^ 2 + b ^ 2] = true
    end

    s = 3
    for c in 1:N
        s1, s, s2 = s, s + 2, s + 2
        for d in c+1:N
            if ab[s1] r[d] = true end
            s1 += s2
            s2 += 2
        end
    end

    return findall(!, r)
end

println("Pythagorean quadruples up to 2200: ", join(quadruples(), ", "))


// version 1.1.3

const val MAX = 2200
const val MAX2 = MAX * MAX - 1

fun main(args: Array<String>) {
    val found = BooleanArray(MAX + 1)       // all false by default
    val p2 = IntArray(MAX + 1) { it * it }  // pre-compute squares

    // compute all possible positive values of d * d - c * c and map them back to d
    val dc = mutableMapOf<Int, MutableList<Int>>()
    for (d in 1..MAX) {
        for (c in 1 until d) {
            val diff = p2[d] - p2[c]
            val v = dc[diff]
            if (v == null)
                dc.put(diff, mutableListOf(d))
            else if (d !in v)
                v.add(d)
        }
    }

    for (a in 1..MAX) {
        for (b in 1..a) {
            if ((a and 1) != 0 && (b and 1) != 0) continue
            val sum = p2[a] + p2[b]
            if (sum > MAX2) continue
            val v = dc[sum]
            if (v != null) v.forEach { found[it] = true }
        }
    }
    println("The values of d <= $MAX which can't be represented:")
    for (i in 1..MAX) if (!found[i]) print("$i ")
    println()
}


load(lapack)$   /* This may hang up in wxMaxima, if this happens, use xMaxima or plain Maxima in a terminal */

a: matrix([12, -51,   4],
          [ 6, 167, -68],
          [-4,  24, -41])$

[q, r]: dgeqrf(a)$

mat_norm(q . r - a, 1);
4.2632564145606011E-14

/* Note: the lapack package is a lisp translation of the fortran lapack library */


import math, strformat, strutils
import arraymancer

####################################################################################################
# First part: QR decomposition.

proc eye(n: Positive): Tensor[float] =
  ## Return the (n, n) identity matrix.
  result = newTensor[float](n.int, n.int)
  for i in 0..<n: result[i, i] = 1

proc norm(v: Tensor[float]): float =
  ## return the norm of a vector.
  assert v.shape.len == 1
  result = sqrt(dot(v, v)) * sgn(v[0]).toFloat

proc houseHolder(a: Tensor[float]): Tensor[float] =
  ## return the house holder of vector "a".
  var v = a / (a[0] + norm(a))
  v[0] = 1
  result = eye(a.shape[0]) - (2 / dot(v, v)) * (v.unsqueeze(1) * v.unsqueeze(0))

proc qrDecomposition(a: Tensor): tuple[q, r: Tensor] =
  ## Return the QR decomposition of matrix "a".
  assert a.shape.len == 2
  let m = a.shape[0]
  let n = a.shape[1]
  result.q = eye(m)
  result.r = a.clone
  for i in 0..<(n - ord(m == n)):
    var h = eye(m)
    h[i..^1, i..^1] = houseHolder(result.r[i..^1, i].squeeze(1))
    result.q = result.q * h
    result.r = h * result.r

####################################################################################################
# Second part: polynomial regression example.

proc lsqr(a, b: Tensor[float]): Tensor[float] =
  let (q, r) = a.qrDecomposition()
  let n = r.shape[1]
  result = solve(r[0..<n, _], (q.transpose() * b)[0..<n])

proc polyfit(x, y: Tensor[float]; n: int): Tensor[float] =
  var z = newTensor[float](x.shape[0], n + 1)
  var t = x.reshape(x.shape[0], 1)
  for i in 0..n: z[_, i] = t^.i.toFloat
  result = lsqr(z, y.transpose())

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

proc printMatrix(a: Tensor) =
  var str: string
  for i in 0..<a.shape[0]:
    let start = str.len
    for j in 0..<a.shape[1]:
      str.addSep(" ", start)
      str.add &"{a[i, j]:8.3f}"
    str.add '\n'
  stdout.write str

proc printVector(a: Tensor) =
  var str: string
  for i in 0..<a.shape[0]:
    str.addSep(" ")
    str.add &"{a[i]:4.1f}"
  echo str

let mat = [[12, -51,   4],
           [ 6, 167, -68],
           [-4,  24, -41]].toTensor.astype(float)

let (q, r) = mat.qrDecomposition()
echo "Q:"
printMatrix q
echo "R:"
printMatrix r
echo()

let x = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10].toTensor.astype(float)
let y = [1, 6, 17, 34, 57, 86, 121, 162, 209, 262, 321].toTensor.astype(float)
echo "polyfit:"
printVector polyfit(x, y, 2)


class FIFO(*array) {
    method pop {
        array.is_empty && die "underflow";
        array.shift;
    }
    method push(*items) {
        array += items;
        self;
    }
    method empty {
        array.len == 0;
    }
}


collections define: #Queue &parents: {ExtensibleArray}.

[email protected](Queue traits) isEmpty [resend].
[email protected](Queue traits) push: obj [q addLast: obj].
[email protected](Queue traits) pop [q removeFirst].
[email protected](Queue traits) pushAll: c [q addAllLast: c].
[email protected](Queue traits) pop: n [q removeFirst: n].


-- initialize
local N = 2200
local ar = {}
for i=1,N do
    ar[i] = false
end

-- process
for a=1,N do
    for b=a,N do
        if (a % 2 ~= 1) or (b % 2 ~= 1) then
            local aabb = a * a + b * b
            for c=b,N do
                local aabbcc = aabb + c * c
                local d = math.floor(math.sqrt(aabbcc))
                if (aabbcc == d * d) and (d <= N) then
                    ar[d] = true
                end
            end
        end
    end
    -- print('done with a='..a)
end

-- print
for i=1,N do
    if not ar[i] then
        io.write(i.." ")
    end
end
print()


max = 2200;
maxsq = max^2;
d = Range[max]^2;
Dynamic[{a, b, Length[d]}]
Do[
 Do[
  c = Range[1, Floor[(maxsq - a^2 - b^2)^(1/2)]];
  dposs = a^2 + b^2 + c^2;
  d = Complement[d, dposs]
  ,
  {b, Floor[(maxsq - a^2)^(1/2)]}
  ]
 ,
 {a, Floor[maxsq^(1/2)]}
 ]
Sqrt[d]


MODULE PythagoreanQuadruples;
FROM FormatString IMPORT FormatString;
FROM RealMath IMPORT sqrt;
FROM Terminal IMPORT WriteString,WriteLn,ReadChar;

PROCEDURE WriteInteger(i : INTEGER);
VAR buffer : ARRAY[0..16] OF CHAR;
BEGIN
    FormatString("%i", buffer, i);
    WriteString(buffer)
END WriteInteger;

(* Main *)
CONST N = 2200;
VAR
    r : ARRAY[0..N] OF BOOLEAN;
    a,b,c,d : INTEGER;
    aabb,aabbcc : INTEGER;
BEGIN
    (* Initialize *)
    FOR a:=0 TO HIGH(r) DO
        r[a] := FALSE
    END;

    (* Process *)
    FOR a:=1 TO N DO
        FOR b:=a TO N DO
            IF (a MOD 2 = 1) AND (b MOD 2 = 1) THEN
                (* For positive odd a and b, no solution *)
                CONTINUE
            END;
            aabb := a*a + b*b;
            FOR c:=b TO N DO
                aabbcc := aabb + c*c;
                d := INT(sqrt(FLOAT(aabbcc)));
                IF (aabbcc = d*d) AND (d <= N) THEN
                    (* solution *)
                    r[d] := TRUE
                END
            END
        END
    END;

    FOR a:=1 TO N DO
        IF NOT r[a] THEN
            (* pritn non-solution *)
            WriteInteger(a);
            WriteString(" ")
        END
    END;
    WriteLn;

    ReadChar
END PythagoreanQuadruples.


-- demo/rosettacode/QRdecomposition.exw
with javascript_semantics

function matrix_mul(sequence a, b)
    integer arows = ~a, acols = ~a[1],
            brows = ~b, bcols = ~b[1]
    if acols!=brows then return 0 end if
    sequence c = repeat(repeat(0,bcols),arows)
    for i=1 to arows do
        for j=1 to bcols do
            for k=1 to acols do
                c[i][j] += a[i][k]*b[k][j]
            end for
        end for
    end for
    return c
end function

function vtranspose(sequence v)
-- transpose a vector of length m into an mx1 matrix,
--                       eg {1,2,3} -> {{1},{2},{3}}
    integer l = length(v)
    sequence res = repeat(0,l)
    for i=1 to l do res[i] = {v[i]} end for
    return res
end function

function mat_col(sequence a, integer col)
    integer la = length(a)
    sequence res = repeat(0,la)
    for i=col to la do
        res[i] = a[i,col]
    end for
    return res
end function

function mat_norm(sequence a)
    atom res = 0
    for i=1 to length(a) do
        res += a[i]*a[i]
    end for
    res = sqrt(res)
    return res
end function

function mat_ident(integer n)
    sequence res = repeat(repeat(0,n),n)
    for i=1 to n do
        res[i,i] = 1
    end for
    return res
end function

function QRHouseholder(sequence a)
    integer cols = length(a[1]),
            rows = length(a),
            m = max(cols,rows),
            n = min(rows,cols)
    sequence q, I = mat_ident(m), Q = I, u, v
--
-- Programming note: The code of this main loop was not as easily
-- written as the first glance might suggest. Explicitly setting
-- to 0 any a[i,j] [etc] that should be 0 but have inadvertently
-- gotten set to +/-1e-15 or thereabouts may be advisable. The
-- commented-out code was retrieved from a backup and should be
-- treated as an example and not be trusted (iirc, it made no
-- difference to the test cases used, so I deleted it, and then
-- had second thoughts about it a few days later).
--
    for j=1 to min(m-1,n) do
        u = mat_col(a,j)
        u[j] -= mat_norm(u)
        v = sq_div(u,mat_norm(u))
        q = sq_sub(I,sq_mul(2,matrix_mul(vtranspose(v),{v})))
        a = matrix_mul(q,a)
--      for row=j+1 to length(a) do
--          a[row][j] = 0
--      end for
        Q = matrix_mul(Q,q)
    end for

    -- Get the upper triangular matrix R.
    sequence R = repeat(repeat(0,n),m)
    for i=1 to n do -- (logically 1 to m(>=n), but no need)
        for j=i to n do
            R[i,j] = a[i,j]
        end for
    end for

    return {Q,R}
end function

constant a = {{12, -51,   4},
              { 6, 167, -68},
              {-4,  24, -41}}

sequence {q,r} = QRHouseholder(a)

ppOpt({pp_Nest,1,pp_IntFmt,"%4d",pp_FltFmt,"%4g",pp_IntCh,false})
?"A"        pp(a)
?"Q"        pp(q)
?"R"        pp(r)
?"Q * R"    pp(matrix_mul(q,r))

function matrix_transpose(sequence mat)
    integer rows = length(mat),
            cols = length(mat[1])
    sequence res = repeat(repeat(0,rows),cols)
    for r=1 to rows do
        for c=1 to cols do
            res[c][r] = mat[r][c]
        end for
    end for
    return res
end function

--?"Q * Q'" pp(matrix_mul(q,matrix_transpose(q))) -- (~1e-16s)
?"Q * Q`"   pp(sq_round(matrix_mul(q,matrix_transpose(q)),1e15))

procedure least_squares()
    sequence x = {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10},
             y = {1, 6, 17, 34, 57, 86, 121, 162, 209, 262, 321},
             a = repeat(repeat(0,3),length(x))
    for i=1 to length(x) do
        for j=1 to 3 do
            a[i,j] = power(x[i],j-1)
        end for
    end for
    {q,r} = QRHouseholder(a)
    sequence t = matrix_transpose(q),
             b = matrix_mul(t,vtranspose(y)),
             z = repeat(0,3)
    for k=3 to 1 by -1 do
        atom s = 0
        if k<3 then
            for j = k+1 to 3 do
                s += r[k,j]*z[j]
            end for
        end if
        z[k] = (b[k][1]-s)/r[k,k]
    end for
    printf(1,"Least-squares solution:\n")
--  printf(1," %v\n",{z})                   -- {1.0,2.0.3,0}
--  printf(1," %v\n",{sq_sub(z,{1,2,3})})   -- (+/- ~1e-14s)
    printf(1," %v\n",{sq_round(z,1e13)})    -- {1,2,3}
end procedure
least_squares()


OrderedCollection extend [
   push: obj [ ^(self add: obj) ]
   pop [
       (self isEmpty) ifTrue: [
          SystemExceptions.NotFound signalOn: self
                reason: 'queue empty'
       ] ifFalse: [
          ^(self removeFirst)
       ]
   ]
]

|f|
f := OrderedCollection new.
f push: 'example'; push: 'another'; push: 'last'.
f pop printNl.
f pop printNl.
f pop printNl.
f isEmpty printNl.
f pop. "queue empty error"


signature QUEUE =
sig
  type 'a queue

  val empty_queue: 'a queue

  exception Empty

  val enq: 'a queue -> 'a -> 'a queue
  val deq: 'a queue -> ('a * 'a queue)
  val empty: 'a queue -> bool
end;


proc push {stackvar value} {
    upvar 1 $stackvar stack
    lappend stack $value
}
proc pop {stackvar} {
    upvar 1 $stackvar stack
    set value [lindex $stack 0]
    set stack [lrange $stack 1 end]
    return $value
}
proc size {stackvar} {
    upvar 1 $stackvar stack
    llength $stack
}
proc empty {stackvar} {
    upvar 1 $stackvar stack
    expr {[size stack] == 0}
}
proc peek {stackvar} {
    upvar 1 $stackvar stack
    lindex $stack 0
}

set Q [list]
empty Q ;# ==> 1 (true)
push Q foo
empty Q ;# ==> 0 (false)
push Q bar
peek Q ;# ==> foo
pop Q ;# ==> foo
peek Q ;# ==> bar


import math

const N = 2_200

template isOdd(n: int): bool = (n and 1) != 0

var r = newSeq[bool](N + 1)

for a in 1..N:
  for b in a..N:
    if a.isOdd and b.isOdd: continue
    let aabb = a * a + b * b
    for c in b..N:
      let aabbcc = aabb + c * c
      d = sqrt(aabbcc.float).int
      if aabbcc == d * d and d <= N: r[d] = true

for i in 1..N:
  if not r[I]: stdout.write i, " "
echo()


program pythQuad;
//find phythagorean Quadrupel up to a,b,c,d <= 2200
//a^2 + b^2 +c^2 = d^2
//find all values of d which are not possible
//brute force
//split in two procedure to reduce register pressure for CPU32

const
  MaxFactor =2200;
  limit = MaxFactor*MaxFactor;
type
  tIdx = NativeUint;
  tSum = NativeUint;

var
  check : array[0..MaxFactor] of boolean;
  checkCnt : LongWord;

procedure Find2(s:tSum;idx:tSum);
//second sum (a*a+b*b) +c*c =?= d*d
var
  s1 : tSum;
  d : tSum;
begin
  d := trunc(sqrt(s+idx*idx));// calculate first sqrt
  For idx := idx to MaxFactor do
  Begin
    s1 := s+idx*idx;
    If s1 <= limit then
    Begin
      while s1 > d*d do //adjust sqrt
        inc(d);
      inc(checkCnt);
      IF s1=d*d then
        check[d] := true;
    end
    else
      Break;
  end;
end;

procedure Find1;
//first sum a*a+b*b
var
  a,b : tIdx;
  s : tSum;
begin
  For a := 1 to MaxFactor do
    For b := a to MaxFactor do
    Begin
      s := a*a+b*b;
      if s < limit then
        Find1(s,b)
      else
        break;
     end;
end;

var
  i : NativeUint;
begin
  Find1;

  For i := 1 to MaxFactor do
    If Not(Check[i]) then
      write(i,' ');
  writeln;
  writeln(CheckCnt,' checks were done');
end.


my $N = 2200;
push @sq, $_**2 for 0 .. $N;
my @not = (0) x $N;
@not[0] = 1;

for my $d (1 .. $N) {
    my $last = 0;
    for my $a (reverse ceiling($d/3) .. $d) {
        for my $b (1 .. ceiling($a/2)) {
            my $ab = $sq[$a] + $sq[$b];
            last if $ab > $sq[$d];
            my $x = sqrt($sq[$d] - $ab);
            if ($x == int $x) {
                $not[$d] = 1;
                $last = 1;
                last
            }
        }
        last if $last;
    }
}

sub ceiling { int $_[0] + 1 - 1e-15 }

for (0 .. $#not) {
    $result .= "$_ " unless $not[$_]
}
print "$result\n"


queue_push() {
    typeset -n q=$1
    shift
    q+=("[email protected]")
}

queue_pop() {
    if queue_empty $1; then
        print -u2 "queue $1 is empty"
        return 1
    fi
    typeset -n q=$1
    print "${q[0]}"     # emit the value of the popped element
    q=( "${q[@]:1}" )   # and remove the first element from the queue
}

queue_empty() {
    typeset -n q=$1
    (( ${#q[@]} == 0 ))
}

queue_peek() {
    typeset -n q=$1
    print "${q[0]}"
}


with javascript_semantics
constant N = 2200,
         N2 = N*N*2
sequence found = repeat(false,N),
         squares = repeat(false,N2)
-- first mark all numbers that can be the sum of two squares
for a=1 to N do
    integer a2 = a*a
    for b=a to N do
        squares[a2+b*b] = true
    end for
end for
-- now find all d such that d^2 - c^2 is in squares
for d=1 to N do
    integer d2 = d*d
    for c=1 to d-1 do
        if squares[d2-c*c] then
            found[d] = true
            exit
        end if
    end for
end for

sequence res = {}
for i=1 to N do
    if not found[i] then res &= i end if
end for
pp(res)


(de quadruples (N)
   (let (AB NIL  S 3  R)
      (for A N
         (for (B A (>= N B) (inc B))
            (idx
               'AB
               (+ (* A A) (* B B))
               T ) ) )
      (for C N
         (let (S1 S  S2)
            (inc 'S 2)
            (setq S2 S)
            (for (D (+ C 1) (>= N D) (inc D))
               (and (idx 'AB S1) (idx 'R D T))
               (inc 'S1 S2)
               (inc 'S2 2) ) ) )
      (make
         (for A N
            (or (idx 'R A) (link A)) ) ) ) )

(println (quadruples 2200))


OpenConsole()
limite.i = 2200
s.i = 3
Dim l.i(limite)
Dim ladd.i(limite * limite * 2)

For x.i = 1 To limite
  x2.i = x * x
  For y = x To limite
    ladd(x2 + y * y) = 1
  Next y
Next x

For x.i = 1 To limite
  s1.i = s
  s.i + 2
  s2.i = s
  For y = x +1 To limite
    If ladd(s1) = 1
      l(y) = 1
    EndIf
    s1 + s2
    s2 + 2
  Next y
Next x

For x.i = 1 To limite
  If l(x) = 0
    Print(Str(x) + " ")
  EndIf
Next x
Input()
CloseConsole()


#!/usr/bin/env python3

import numpy as np

def qr(A):
    m, n = A.shape
    Q = np.eye(m)
    for i in range(n - (m == n)):
        H = np.eye(m)
        H[i:, i:] = make_householder(A[i:, i])
        Q = np.dot(Q, H)
        A = np.dot(H, A)
    return Q, A

def make_householder(a):
    v = a / (a[0] + np.copysign(np.linalg.norm(a), a[0]))
    v[0] = 1
    H = np.eye(a.shape[0])
    H -= (2 / np.dot(v, v)) * np.dot(v[:, None], v[None, :])
    return H

# task 1: show qr decomp of wp example
a = np.array(((
    (12, -51,   4),
    ( 6, 167, -68),
    (-4,  24, -41),
)))

q, r = qr(a)
print('q:\n', q.round(6))
print('r:\n', r.round(6))

# task 2: use qr decomp for polynomial regression example
def polyfit(x, y, n):
    return lsqr(x[:, None]**np.arange(n + 1), y.T)

def lsqr(a, b):
    q, r = qr(a)
    _, n = r.shape
    return np.linalg.solve(r[:n, :], np.dot(q.T, b)[:n])

x = np.array((0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
y = np.array((1, 6, 17, 34, 57, 86, 121, 162, 209, 262, 321))

print('\npolyfit:\n', polyfit(x, y, 2))


init() {echo > fifo}
push() {echo $1 >> fifo }
pop() {head -1 fifo ; (cat fifo | tail -n +2)|sponge fifo}
empty() {cat fifo | wc -l}


[fifo_create []].
[fifo_push swap cons].
[fifo_pop [[*rest a] : [*rest] a] view].
[fifo_empty? dup empty?].


def quad(top=2200):
    r = [False] * top
    ab = [False] * (top * 2)**2
    for a in range(1, top):
        for b in range(a, top):
            ab[a * a + b * b] = True
    s = 3
    for c in range(1, top):
        s1, s, s2 = s, s + 2, s + 2
        for d in range(c + 1, top):
            if ab[s1]:
                r[d] = True
            s1 += s2
            s2 += 2
    return [i for i, val in enumerate(r) if not val and i]

if __name__ == '__main__':
    n = 2200
    print(f"Those values of d in 1..{n} that can't be represented: {quad(n)}")


squares <- d <- seq_len(2200)^2
aAndb <- outer(squares, squares, '+')
aAndb <- aAndb[upper.tri(aAndb, diag = TRUE)]
sapply(squares, function(c) d <<- setdiff(d, aAndb + c))
print(sqrt(d))


#lang racket

(require data/bit-vector)

(define (quadruples top)
  (define top+1 (add1 top))
  (define 1..top (in-range 1 top+1))
  (define r (make-bit-vector top+1))
  (define ab (make-bit-vector (add1 (sqr (* top 2)))))
  (for* ((a 1..top) (b (in-range a top+1))) (bit-vector-set! ab (+ (sqr a) (sqr b)) #t))

  (for/fold ((s 3))
            ((c 1..top))
    (for/fold ((s1 s) (s2 (+ s 2)))
              ((d (in-range (add1 c) top+1)))
      (when (bit-vector-ref ab s1)
        (bit-vector-set! r d #t))
      (values (+ s1 s2) (+ s2 2)))
    (+ 2 s))

  (for/list ((i (in-naturals 1)) (v (in-bit-vector r 1)) #:unless v) i))

(define (report n)
  (printf "Those values of d in 1..~a that can't be represented: ~a~%" n (quadruples n)))

(report 2200)


my \N = 2200;
my @sq = (0 .. N)»²;
my @not = False xx N;
@not[0] = True;

(1 .. N).race.map: -> $d {
    my $last = 0;
    for $d ... ($d/3).ceiling -> $a {
        for 1 .. ($a/2).ceiling -> $b {
            last if (my $ab = @sq[$a] + @sq[$b]) > @sq[$d];
            if (@sq[$d] - $ab).sqrt.narrow ~~ Int {
                @not[$d] = True;
                $last = 1;
                last
            }
        }
        last if $last;
    }
}

say @not.grep( *.not, :k );


# R has QR decomposition built-in (using LAPACK or LINPACK)

a <- matrix(c(12, -51, 4, 6, 167, -68, -4, 24, -41), nrow=3, ncol=3, byrow=T)
d <- qr(a)
qr.Q(d)
qr.R(d)

# now fitting a polynomial
x <- 0:10
y <- 3*x^2 + 2*x + 1

# using QR decomposition directly
a <- cbind(1, x, x^2)
qr.coef(qr(a), y)

# using least squares
a <- cbind(x, x^2)
lsfit(a, y)$coefficients

# using a linear model
xx <- x*x
m <- lm(y ~ x + xx)
coef(m)


# sub householder translated from https://codereview.stackexchange.com/questions/120978/householder-transformation

use v6;

sub identity(Int:D $m --> Array of Array) {
   my Array @M;

   for 0 ..^ $m -> $i {
      @M.push: [0 xx $m];
      @M[$i; $i] = 1;
   }

   @M;
}

multi multiply(Array:D @A, @b where Array:D --> Array) {
   my @c;

   for ^@A X ^@b -> ($i, $j) {
      @c[$i] += @A[$i; $j] * @b[$j];
   }

   @c;
}

multi multiply(Array:D @A, Array:D @B --> Array of Array) {
   my Array @C;

   for ^@A X ^@B[0] -> ($i, $j) {
      @C[$i; $j] += @A[$i; $_] * @B[$_; $j] for ^@B;
   }

   @C;
}

sub transpose(Array:D @M --> Array of Array) {
   my ($rows, $cols) = (@M.elems, @M[0].elems);

   my Array @T;

   for ^$cols X ^$rows -> ($j, $i) {
      @T[$j; $i] = @M[$i; $j];
   }

   @T;
}

####################################################
# NOTE: @A gets overwritten and becomes @R, only need
# to return @Q.
####################################################
sub householder(Array:D @A --> Array) {
   my Int ($m, $n) = (@A.elems, @A[0].elems);
   my @v = 0 xx $m;
   my Array @Q = identity($m);

   for 0 ..^ $n -> $k {
      my Real $sum = 0;
      my Real $A0 = @A[$k; $k];
      my Int $sign = $A0 < 0 ?? -1 !! 1;

      for $k ..^ $m -> $i {
         $sum += @A[$i; $k] * @A[$i; $k];
      }

      my Real $sqr_sum = $sign * sqrt($sum);
      my Real $tmp = sqrt(2 * ($sum + $A0 * $sqr_sum));
      @v[$k] = ($sqr_sum  + $A0) / $tmp;

      for ($k + 1) ..^ $m -> $i {
         @v[$i] = @A[$i; $k] / $tmp;
      }

      for 0 ..^ $n -> $j {
         $sum = 0;

         for $k ..^ $m -> $i {
            $sum += @v[$i] * @A[$i; $j];
         }

         for $k ..^ $m -> $i {
            @A[$i; $j] -= 2 * @v[$i] * $sum;
         }
      }

      for 0 ..^ $m -> $j {
         $sum = 0;

         for $k ..^ $m -> $i {
            $sum += @v[$i] * @Q[$i; $j];
         }

         for $k ..^ $m -> $i {
            @Q[$i; $j] -= 2 * @v[$i] * $sum;
         }
      }
   }

   @Q
}

sub dotp(@a where Array:D, @b where Array:D --> Real) {
   [+] @a >>*<< @b;
}

sub upper-solve(Array:D @U, @b where Array:D, Int:D $n --> Array) {
   my @y = 0 xx $n;

   @y[$n - 1] = @b[$n - 1] / @U[$n - 1; $n - 1];

   for reverse ^($n - 1) -> $i {
      @y[$i] = (@b[$i] - (dotp(@U[$i], @y))) / @U[$i; $i];
   }

   @y;
}

sub polyfit(@x where Array:D, @y where Array:D, Int:D $n) {
   my Int $m = @x.elems;
   my Array @V;

   # Vandermonde matrix
   for ^$m X (0 .. $n) -> ($i, $j) {
      @V[$i; $j] = @x[$i] ** $j
   }

   # least squares
   my $Q = householder(@V);
   my @b = multiply($Q, @y);

   return upper-solve(@V, @b, $n + 1);
}

sub print-mat(Array:D @M, Str:D $name) {
   my Int ($m, $n) = (@M.elems, @M[0].elems);
   print "\n$name:\n";

   for 0 ..^ $m -> $i {
      for 0 ..^ $n -> $j {
         print @M[$i; $j].fmt("%12.6f ");
      }

      print "\n";
   }
}

sub MAIN() {
   ############
   # 1st part #
   ############
   my Array @A = (
      [12, -51,   4],
      [ 6, 167, -68],
      [-4,  24, -41],
      [-1,   1,   0],
      [ 2,   0,   3]
   );

   print-mat(@A, 'A');
   my $Q = householder(@A);
   $Q = transpose($Q);
   print-mat($Q, 'Q');
   # after householder, @A is now @R
   print-mat(@A, 'R');
   print-mat(multiply($Q, @A), 'check Q x R = A');

   ############
   # 2nd part #
   ############
   my @x = [^11];
   my @y = [1, 6, 17, 34, 57, 86, 121, 162, 209, 262, 321];

   my @coef = polyfit(@x, @y, 2);

   say
      "\npolyfit:\n",
      <constant X X^2>.fmt("%12s"),
      "\n",
      @coef.fmt("%12.6f");
}


Public queue As New Collection

Private Sub push(what As Variant)
    queue.Add what
End Sub

Private Function pop() As Variant
    If queue.Count > 0 Then
        what = queue(1)
        queue.Remove 1
    Else
        what = CVErr(461)
    End If
    pop = what
End Function

Private Function empty_()
    empty_ = queue.Count = 0
End Function


' Queue Definition - VBScript
Option Explicit
Dim queue, i, x
Set queue = CreateObject("System.Collections.ArrayList")
If Not empty_(queue) Then Wscript.Echo queue.Count
push queue, "Banana"
push queue, "Apple"
push queue, "Pear"
push queue, "Strawberry"
Wscript.Echo "Count=" & queue.Count
Wscript.Echo pull(queue) & " - Count=" & queue.Count '
Wscript.Echo "Head=" & queue.Item(0)
Wscript.Echo "Tail=" & queue.Item(queue.Count-1)
Wscript.Echo queue.IndexOf("Pear", 0)
For i=1 To queue.Count
	Wscript.Echo join(queue.ToArray(), ", ")
	x = pull(queue)
Next 'i

Sub push(q, what)
    q.Add what
End Sub 'push

Function pull(q)
	Dim what
    If q.Count > 0 Then
        what = q(0)
        q.RemoveAt 0
    Else
        what = ""
    End If
    pull = what
End Function 'pull

Function empty_(q)
    empty_ = q.Count = 0
End Function 'empty_


/*REXX pgm computes/shows (integers),  D  that aren't possible for: a² + b² + c²  =  d² */
parse arg hi .                                   /*obtain optional argument from the CL.*/
if hi=='' | hi==","  then hi=2200;  high= 3 * hi /*Not specified?  Then use the default.*/
@.=.                                             /*array of integers to be squared.     */
!.=.                                             /*  "    "     "    squared.           */
       do j=1  for high                          /*precompute possible squares (to max).*/
       _= j*j;   !._= j;   if j<=hi  then @.j= _ /*define a square; D  value; squared # */
       end   /*j*/
d.=.                                             /*array of possible solutions  (D)     */
       do       a=1  for hi-2;  aodd= a//2       /*go hunting for solutions to equation.*/
          do    b=a   to hi-1;
          if aodd  then  if b//2  then iterate   /*Are  A  and  B  both odd?  Then skip.*/
          ab = @.a + @.b                         /*calculate sum of  2  (A,B)   squares.*/
             do c=b   to hi;     abc= ab  + @.c  /*    "      "   "  3  (A,B,C)    "    */
             if !.abc==.  then iterate           /*Not a square? Then skip it*/
             s=!.abc;    d.s=                    /*define this D solution as being found*/
             end   /*c*/
          end      /*b*/
       end         /*a*/
say
say 'Not possible positive integers for   d ≤' hi "  using equation:  a² + b² + c²  =  d²"
say
$=                                               /* [↓]  find all the  "not possibles". */
       do p=1  for hi;   if d.p==.  then $=$ p   /*Not possible? Then add it to the list*/
       end   /*p*/                               /* [↓]  display list of not-possibles. */
say substr($, 2)                                 /*stick a fork in it,  we're all done. */


# Project : Pythagorean quadruples

limit = 2200
pq = list(limit)
for n = 1 to limit
      for m = 1 to limit
           for p = 1 to limit
                 for x = 1 to limit
                       if pow(x,2) = pow(n,2) + pow(m,2) + pow(p,2)
                          pq[x] = 1
                       ok
                 next
           next
      next
next
pqstr = ""
for d = 1 to limit
      if pq[d] = 0
         pqstr = pqstr + d + " "
      ok
next
see pqstr + nl


n = 2200
l_add, l = {}, {}
1.step(n) do |x|
  x2 = x*x
  x.step(n) {|y| l_add[x2 + y*y] = true}
end

s = 3
1.step(n) do |x|
  s1 = s
  s += 2
  s2 = s
  (x+1).step(n) do |y|
    l[y] = true if l_add[s1]
    s1 += s2
    s2 += 2
  end
end

puts (1..n).reject{|x| l[x]}.join(" ")


import util::Math;
import Prelude;
import vis::Figure;
import vis::Render;

public rel[real,real,real] QRdecomposition(rel[real x, real y, real v] matrix){
	//orthogonalcolumns
	oc = domainR(matrix, {0.0});
	for (x <- sort(toList(domain(matrix)-{0.0}))){
		c = domainR(matrix, {x});
		o = domainR(oc, {x-1});

		for (n <- [1.0 .. x]){
			o = domainR(oc, {n-1});
			c = matrixSubtract(c, matrixMultiplybyN(o, matrixDotproduct(o, c)/matrixDotproduct(o, o)));
			}

		oc += c;
	}

	Q = {};
	//from orthogonal to orthonormal columns
	for (el <- oc){
		c = domainR(oc, {el[0]});
		Q += matrixNormalize({el}, c);
	}

	//from Q to R
	R= matrixMultiplication(matrixTranspose(Q), matrix);
	R= {<x,y,toReal(round(v))> | <x,y,v> <- R};

	println("Q:");
	iprintlnExp(Q);
	println();
	println("R:");
	return R;
}

//a function that takes the transpose of a matrix, see also Rosetta Code problem "Matrix transposition"
public rel[real, real, real] matrixTranspose(rel[real x, real y, real v] matrix){
	return {<y, x, v> | <x, y, v> <- matrix};
}

//a function to normalize an element of a matrix by the normalization of a column
public rel[real,real,real] matrixNormalize(rel[real x, real y, real v] element, rel[real x, real y, real v] column){
	normalized = 1.0/nroot((0.0 | it + v*v | <x,y,v> <- column), 2);
	return matrixMultiplybyN(element, normalized);
}

//a function that takes the dot product, see also Rosetta Code problem "Dot product"
public real matrixDotproduct(rel[real x, real y, real v] column1, rel[real x, real y, real v] column2){
	return (0.0 | it + v1*v2 | <x1,y1,v1> <- column1, <x2,y2,v2> <- column2, y1==y2);
}

//a function to subtract two columns
public rel[real,real,real] matrixSubtract(rel[real x, real y, real v] column1, rel[real x, real y, real v] column2){
	return {<x1,y1,v1-v2> | <x1,y1,v1> <- column1, <x2,y2,v2> <- column2, y1==y2};
}

//a function to multiply a column by a number
public rel[real,real,real] matrixMultiplybyN(rel[real x, real y, real v] column, real n){
	return {<x,y,v*n> | <x,y,v> <- column};
}

//a function to perform matrix multiplication, see also Rosetta Code problem "Matrix multiplication".
public rel[real, real, real] matrixMultiplication(rel[real x, real y, real v] matrix1, rel[real x, real y, real v] matrix2){
	if (max(matrix1.x) == max(matrix2.y)){
		p = {<x1,y1,x2,y2, v1*v2> | <x1,y1,v1> <- matrix1, <x2,y2,v2> <- matrix2};

		result = {};
		for (y <- matrix1.y){
			for (x <- matrix2.x){
				v = (0.0 | it + v | <x1, y1, x2, y2, v> <- p,  x==x2 && y==y1, x1==y2 && y2==x1);
				result += <x,y,v>;
			}
		}
		return result;
	}
	else throw "Matrix sizes do not match.";
}

// a function to visualize the result
public void displayMatrix(rel[real x, real y, real v] matrix){
	points = [box(text("<v>"), align(0.3333*(x+1),0.3333*(y+1)),shrink(0.25)) | <x,y,v> <- matrix];
	render(overlay([*points], aspectRatio(1.0)));
}

//a matrix, given by a relation of <x-coordinate, y-coordinate, value>.
public rel[real x, real y, real v] matrixA = {
<0.0,0.0,12.0>, <0.0,1.0, 6.0>, <0.0,2.0,-4.0>,
<1.0,0.0,-51.0>, <1.0,1.0,167.0>, <1.0,2.0,24.0>,
<2.0,0.0,4.0>, <2.0,1.0,-68.0>, <2.0,2.0,-41.0>
};


import java.io.{PrintWriter, StringWriter}

import Jama.{Matrix, QRDecomposition}

object QRDecomposition extends App {
  val matrix =
    new Matrix(
      Array[Array[Double]](Array(12, -51, 4),
        Array(6, 167, -68),
        Array(-4, 24, -41)))
  val d = new QRDecomposition(matrix)

  def toString(m: Matrix): String = {
    val sw = new StringWriter
    m.print(new PrintWriter(sw, true), 8, 6)
    sw.toString
  }

  print(toString(d.getQ))
  print(toString(d.getR))

}


const max_tail = 256

struct Queue<T> {
mut:
	data  []T
	tail int
	head  int
}

fn (mut queue Queue<T>) push(value T) {
	if queue.tail >= max_tail || queue.tail < queue.head {
		return
	}
	println('push: $value')
	queue.data << value
	queue.tail++
}

fn (mut queue Queue<T>) pop() !T {
	if queue.tail > 0 && queue.head < queue.tail {
		result := queue.data[queue.head]
		queue.head++
		println('Dequeue: top of Queue was $result')
		return result
	}
	return error('Queue Underflow!!')
}

fn (queue Queue<T>) peek() !T {
	if queue.tail > 0 && queue.head < queue.tail {
		result := queue.data[queue.head]
		println('Peek: top of Queue is $result')
		return result
	}
	return error('Out of Bounds...')
}

fn (queue Queue<T>) empty() bool {
	return queue.tail == 0
}

fn main() {
	mut queue := Queue<f64>{}
	println('Queue is empty? ' + if queue.empty() { 'Yes' } else { 'No' })
	queue.push(5.0)
	queue.push(4.2)
	println('Queue is empty? ' + if queue.empty() { 'Yes' } else { 'No' })
	queue.peek() or { return }
	queue.pop() or { return }
	queue.pop() or { return }
	queue.push(1.2)
}


def (queue seq)
  (tag queue (list seq lastcons.seq len.seq))

def (enq x q)
  do1 x
    let (l last len) rep.q
      rep.q.2 <- (len + 1)
      if no.l
        rep.q.1 <- (rep.q.0 <- list.x)
        rep.q.1 <- (cdr.last <- list.x)

def (deq q)
  let (l last len) rep.q
    ret ans car.l
      unless zero?.len
        rep.q.2 <- (len - 1)
      rep.q.0 <- cdr.l

def (len q) :case (isa queue q)
  rep.q.2


object PythagoreanQuadruple extends App {
  val MAX = 2200
  val MAX2: Int = MAX * MAX * 2
  val found = Array.ofDim[Boolean](MAX + 1)
  val a2b2 = Array.ofDim[Boolean](MAX2 + 1)
  var s = 3
  for (a <- 1 to MAX) {
    val a2 = a * a

    for (b <- a to MAX) a2b2(a2 + b * b) = true
  }

  for (c <- 1 to MAX) {
    var s1 = s
    s += 2
    var s2 = s
    for (d <- (c + 1) to MAX) {
      if (a2b2(s1)) found(d) = true
      s1 += s2
      s2 += 2
    }
  }

  println(f"The values of d <= ${MAX}%d which can't be represented:")
  val notRepresented = (1 to MAX).filterNot(d =>  found(d) )
  println(notRepresented.mkString(" "))

}


# Finds all solutions (a,b) such that: a^2 + b^2 = n^2
func sum_of_two_squares(n) is cached {

    n == 0 && return [[0, 0]]

    var prod1 = 1
    var prod2 = 1

    var prime_powers = []

    for p,e in (n.factor_exp) {
        if (p % 4 == 3) {                  # p = 3 (mod 4)
            e.is_even || return []         # power must be even
            prod2 *= p**(e >> 1)
        }
        elsif (p == 2) {                   # p = 2
            if (e.is_even) {               # power is even
                prod2 *= p**(e >> 1)
            }
            else {                         # power is odd
                prod1 *= p
                prod2 *= p**((e - 1) >> 1)
                prime_powers.append([p, 1])
            }
        }
        else {                             # p = 1 (mod 4)
            prod1 *= p**e
            prime_powers.append([p, e])
        }
    }

    prod1 == 1 && return [[prod2, 0]]
    prod1 == 2 && return [[prod2, prod2]]

    # All the solutions to the congruence: x^2 = -1 (mod prod1)
    var square_roots = gather {
        gather {
            for p,e in (prime_powers) {
                var pp = p**e
                var r = sqrtmod(-1, pp)
                take([[r, pp], [pp - r, pp]])
            }
        }.cartesian { |*a|
            take(Math.chinese(a...))
        }
    }

    var solutions = []

    for r in (square_roots) {

        var s = r
        var q = prod1

        while (s*s > prod1) {
            (s, q) = (q % s, s)
        }

        solutions.append([prod2 * s, prod2 * (q % s)])
    }

    for p,e in (prime_powers) {
        for (var i = e%2; i < e; i += 2) {

            var sq = p**((e - i) >> 1)
            var pp = p**(e - i)

            solutions += (
                __FUNC__(prod1 / pp).map { |pair|
                    pair.map {|r| sq * prod2 * r }
                }
            )
        }
    }

    solutions.map     {|pair| pair.sort } \
             .uniq_by {|pair| pair[0]   } \
             .sort_by {|pair| pair[0]   }
}

# Finds all solutions (a,b,c) such that: a^2 + b^2 + c^2 = n^2
func sum_of_three_squares(n) {
    gather {
        for k in (1 .. n//3) {
            var t = sum_of_two_squares(n**2 - k**2) || next
            take(t.map { [k, _...] }...)
        }
    }
}

say gather {
    for n in (1..2200) {
        sum_of_three_squares(n) || take(n)
    }
}


import <Utilities/Math.sl>;
import <Utilities/Sequence.sl>;
import <Utilities/Conversion.sl>;

main :=
    let
        qrTest := [[12.0, -51.0,   4.0],
                   [ 6.0, 167.0, -68.0],
                   [-4.0,  24.0, -41.0]];

        qrResult := qr(qrTest);

        x := 1.0*(0 ... 10);
        y := 1.0*[1, 6, 17, 34, 57, 86, 121, 162, 209, 262, 321];

        regResult := polyfit(x, y, 2);
    in
        "q:\n" ++ delimit(delimit(floatToString(qrResult[1], 6), ','), '\n') ++ "\n\n" ++
        "r:\n" ++ delimit(delimit(floatToString(qrResult[2], 1), ','), '\n') ++ "\n\n" ++
        "polyfit:\n" ++ "[" ++ delimit(floatToString(regResult, 1), ',') ++ "]";

//---Polynomial Regression---

polyfit(x(1), y(1), n) :=
    let
        a[j] := x ^ j foreach j within 0 ... n;
    in
        lsqr(transpose(a), transpose([y]));

lsqr(a(2), b(2)) :=
    let
        qrDecomp := qr(a);
        prod := mm(transpose(qrDecomp[1]), b);
    in
        solveUT(qrDecomp[2], prod);

solveUT(r(2), b(2)) :=
    let
        n := size(r[1]);
    in
        solveUTHelper(r, b, n, duplicate(0.0, n));

solveUTHelper(r(2), b(2), k, x(1)) :=
    let
        n := size(r[1]);
        newX :=  setElementAt(x, k, (b[k][1] - sum(r[k][(k+1) ... n] * x[(k+1) ... n])) / r[k][k]);
    in
        x when k <= 0
    else
        solveUTHelper(r, b, k - 1, newX);

//---QR Decomposition---

qr(A(2)) := qrHelper(A, id(size(A)), 1);

qrHelper(A(2), Q(2), i) :=
    let
        m := size(A);
        n := size(A[1]);

        householder := makeHouseholder(A[i ... m, i]);

        H[j,k] :=
                householder[j - i + 1][k - i + 1] when j >= i and k >= i
            else
                1.0 when j = k else 0.0
            foreach j within 1 ... m,
                    k within 1 ... m;
    in
        [Q,A] when i > (n - 1 when m = n else n)
    else
        qrHelper(mm(H, A), mm(Q, H), i + 1);

makeHouseholder(a(1)) :=
    let
        v := [1.0] ++ tail(a / (a[1] + sqrt(sum(a ^ 2)) * sign(a[1])));

        H := id(size(a)) - (2.0 / mm([v], transpose([v])))[1,1] * mm(transpose([v]), [v]);
    in
        H;

//---Utilities---

id(n)[i,j] := 1.0 when i = j else 0.0
              foreach i within 1 ... n,
                      j within 1 ... n;

mm(A(2), B(2))[i,j] := sum( A[i] * transpose(B)[j] );


signature RADCATFIELD = sig
type real
val zero : real
val one : real
val + : real * real -> real
val - : real * real -> real
val * : real * real -> real
val / : real * real -> real
val sign : real -> real
val sqrt : real -> real
end

functor QR(F: RADCATFIELD) = struct
structure A = struct
local
    open Array
in
fun unitVector n = tabulate (n, fn i => if i=0 then F.one else F.zero)
fun map f x = tabulate(length x, fn i => f(sub(x,i)))
fun map2 f (x, y) = tabulate(length x, fn i => f(sub(x,i),sub(y,i)))
val op + = map2 F.+
val op - = map2 F.-
val op * = map2 F.*
fun multc(c,x) = array(length x,c)*x
fun dot (x,y) = foldl F.+ F.zero (x*y)
fun outer f (x,y) =
    Array2.tabulate Array2.RowMajor (length x, length y,
				     fn (i,j) => f(sub(x,i),sub(y,j)))
fun copy x = map (fn x => x) x
fun fromVector v = tabulate(Vector.length v, fn i => Vector.sub(v,i))
fun slice(x,i,sz) =
    let	open ArraySlice
	val s = slice(x,i,sz)
    in Array.tabulate(length s, fn i => sub(s,i)) end
end
end
structure M = struct
local
    open Array2
in
fun map f x = tabulate RowMajor (nRows x, nCols x, fn (i,j) => f(sub(x,i,j)))
fun map2 f (x, y) =
    tabulate RowMajor (nRows x, nCols x, fn (i,j) => f(sub(x,i,j),sub(y,i,j)))
fun scalarMatrix(m, x) = tabulate RowMajor (m,m,fn (i,j) => if i=j then x else F.zero)
fun multc(c, x) = map (fn xij => F.*(c,xij)) x
val op + = map2 F.+
val op - = map2 F.-
fun column(x,i) = A.fromVector(Array2.column(x,i))
fun row(x,i) = A.fromVector(Array2.row(x,i))
fun x*y = tabulate RowMajor (nRows x, nCols y,
			     fn (i,j) => A.dot(row(x,i), column(y,j)))
fun multa(x,a) = Array.tabulate (nRows x, fn i => A.dot(row(x,i), a))
fun copy x = map (fn x => x) x
fun subMatrix(h, i1, i2, j1, j2) =
    tabulate RowMajor (Int.+(Int.-(i2,i1),1),
		       Int.+(Int.-(j2,j1),1),
		       fn (a,b) => sub(h,Int.+(i1,a),Int.+(j1,b)))
fun transpose m = tabulate RowMajor (nCols m,
				     nRows m,
				     fn (i,j) => sub(m,j,i))
fun updateSubMatrix(h,i,j,s) =
    tabulate RowMajor (nRows s, nCols s, fn (a,b) => update(h,Int.+(i,a),Int.+(j,b),sub(s,a,b)))
end
end
fun toList a =
    List.tabulate(Array2.nRows a, fn i => List.tabulate(Array2.nCols a, fn j => Array2.sub(a,i,j)))
fun householder a =
    let open Array
	val m = length a
	val len = F.sqrt(A.dot(a,a))
	val u = A.+(a, A.multc(F.*(len,F.sign(sub(a,0))), A.unitVector m))
	val v = A.multc(F./(F.one,sub(u,0)), u)
	val beta = F./(F.+(F.one,F.one),A.dot(v,v))
    in
	M.-(M.scalarMatrix(m,F.one), M.multc(beta,A.outer F.* (v,v)))
    end
fun qr mat =
    let open Array2
	val (m,n) = dimensions mat
	val upperIndex = if m=n then Int.-(n,1) else n
	fun loop(i,qm,rm) = if i=upperIndex then {q=qm,r=rm} else
			    let val x = A.slice(A.fromVector(column(rm,i)),i,NONE)
				val h = M.scalarMatrix(m,F.one)
				val _ = M.updateSubMatrix(h,i,i,householder x)
			    in
				loop(Int.+(i,1), M.*(qm,h), M.*(h,rm))
			    end
    in
	loop(0, M.scalarMatrix(m,F.one), mat)
    end
fun solveUpperTriangular(r,b) =
    let open Array
	val n = Array2.nCols r
	val x = array(n, F.zero)
	fun loop k =
	    let val index = Int.min(Int.-(n,1),Int.+(k,1))
		val _ = update(x,k,
			       F./(F.-(sub(b,k),
				       A.dot(A.slice(x,index,NONE),
					     A.slice(M.row(r,k),index,NONE))),
				   Array2.sub(r,k,k)))
	    in
		if k=0 then x else loop(Int.-(k,1))
	    end
    in
	loop (Int.-(n,1))
    end
fun lsqr(a,b) =
    let val {q,r} = qr a
	val n = Array2.nCols r
    in
	solveUpperTriangular(M.subMatrix(r, 0, Int.-(n,1), 0, Int.-(n,1)),
			     M.multa(M.transpose(q), b))
    end
fun pow(x,1) = x
  | pow(x,n) = F.*(x,pow(x,Int.-(n,1)))
fun polyfit(x,y,n) =
    let open Array2
	val a = tabulate RowMajor (Array.length x,
				   Int.+(n,1),
				   fn (i,j) => if j=0 then F.one else
					       pow(Array.sub(x,i),j))
    in
	lsqr(a,y)
    end
end


import "/queue" for Queue

var q = Queue.new()
var item = q.pop()
if (item == null) {
    System.print("ERROR: attempted to pop from an empty queue")
} else {
    System.print("'%(item)' was popped")
}


(define-class queue
    (instance-variables vals))

(define-method (queue 'initialize)
    (setq vals '())
    self)

(define-method (queue 'push x)
    (setq vals (nconc vals (cons x nil))))

(define-method (queue 'pop)
    (define val (car vals))
    (setq vals (cdr vals))
    val)

(define-method (queue 'emptyp)
    (null vals))


func missingD(upTo n: Int) -> [Int] {
  var a2 = 0, s = 3, s1 = 0, s2 = 0
  var res = [Int](repeating: 0, count: n + 1)
  var ab = [Int](repeating: 0, count: n * n * 2 + 1)

  for a in 1...n {
    a2 = a * a

    for b in a...n {
      ab[a2 + b * b] = 1
    }
  }

  for c in 1..<n {
    s1 = s
    s += 2
    s2 = s

    for d in c+1...n {
      if ab[s1] != 0 {
        res[d] = 1
      }

      s1 += s2
      s2 += 2
    }
  }

  return (1...n).filter({ res[$0] == 0 })
}

print(missingD(upTo: 2200))


Const n = 2200
Public Sub pq()
    Dim s As Long, s1 As Long, s2 As Long, x As Long, x2 As Long, y As Long: s = 3
    Dim l(n) As Boolean, l_add(9680000) As Boolean '9680000=n * n * 2
    For x = 1 To n
        x2 = x * x
        For y = x To n
            l_add(x2 + y * y) = True
        Next y
    Next x
    For x = 1 To n
        s1 = s
        s = s + 2
        s2 = s
        For y = x + 1 To n
            If l_add(s1) Then l(y) = True
            s1 = s1 + s2
            s2 = s2 + 2
        Next
    Next
    For x = 1 To n
        If Not l(x) Then Debug.Print x;
    Next
    Debug.Print
End Sub


var N = 2200
var N2 = N * N * 2
var s = 3
var s1 = 0
var s2 = 0
var r = List.filled(N + 1, false)
var ab = List.filled(N2 + 1, false)

for (a in 1..N) {
    var a2 = a * a
    for (b in a..N) ab[a2 + b*b] = true
}

for (c in 1..N) {
    s1 = s
    s = s + 2
    s2 = s
    var d = c + 1
    while (d <= N) {
        if (ab[s1]) r[d] = true
        s1 = s1 + s2
        s2 = s2 + 2
        d = d + 1
    }
}

for (d in 1..N) {
    if (!r[d]) System.write("%(d) ")
}
System.print()


package require Tcl 8.5
namespace path {::tcl::mathfunc ::tcl::mathop}
proc sign x {expr {$x == 0 ? 0 : $x < 0 ? -1 : 1}}
proc norm vec {
    set s 0
    foreach x $vec {set s [expr {$s + $x**2}]}
    return [sqrt $s]
}
proc unitvec n {
    set v [lrepeat $n 0.0]
    lset v 0 1.0
    return $v
}
proc I n {
    set m [lrepeat $n [lrepeat $n 0.0]]
    for {set i 0} {$i < $n} {incr i} {lset m $i $i 1.0}
    return $m
}

proc arrayEmbed {A B row col} {
    # $A will be copied automatically; Tcl values are copy-on-write
    lassign [size $B] mb nb
    for {set i 0} {$i < $mb} {incr i} {
	for {set j 0} {$j < $nb} {incr j} {
	    lset A [expr {$row + $i}] [expr {$col + $j}] [lindex $B $i $j]
	}
    }
    return $A
}

# Unlike the Common Lisp version, here we use a specialist subcolumn
# extraction function: like that, there's a lot less intermediate memory allocation
# and the code is actually clearer.
proc subcolumn {A size column} {
    for {set i $column} {$i < $size} {incr i} {lappend x [lindex $A $i $column]}
    return $x
}

proc householder A {
    lassign [size $A] m
    set U [m+ $A [.* [unitvec $m] [expr {[norm $A] * [sign [lindex $A 0 0]]}]]]
    set V [./ $U [lindex $U 0 0]]
    set beta [expr {2.0 / [lindex [matrix_multiply [transpose $V] $V] 0 0]}]
    return [m- [I $m] [.* [matrix_multiply $V [transpose $V]] $beta]]
}

proc qrDecompose A {
    lassign [size $A] m n
    set Q [I $m]
    for {set i 0} {$i < ($m==$n ? $n-1 : $n)} {incr i} {
	# Construct the Householder matrix
	set H [arrayEmbed [I $m] [householder [subcolumn $A $n $i]] $i $i]
	# Apply to build the decomposition
	set Q [matrix_multiply $Q $H]
	set A [matrix_multiply $H $A]
    }
    return [list $Q $A]
}


include c:\cxpl\codes;
def Size=8;
int Fifo(Size);
int In, Out;            \fill and empty indexes into Fifo

proc Push(A);           \Add integer A to queue
int  A;                 \(overflow not detected)
[Fifo(In):= A;
In:= In+1;
if In >= Size then In:= 0;
];

func Pop;               \Return first integer in queue
int  A;
[if Out=In then                   \if popping empty queue
    [Text(0, "Error");  exit 1];  \ then exit program with error code 1
A:= Fifo(Out);
Out:= Out+1;
if Out >= Size then Out:= 0;
return A;
];

func Empty;             \Return 'true' if queue is empty
return In = Out;

[In:= 0;  Out:= 0;
Push(0);
Text(0, if Empty then "true" else "false");  CrLf(0);
IntOut(0, Pop);  CrLf(0);
Push(1);
Push(2);
Push(3);
IntOut(0, Pop);  CrLf(0);
IntOut(0, Pop);  CrLf(0);
IntOut(0, Pop);  CrLf(0);
Text(0, if Empty then "true" else "false");  CrLf(0);

\A 256-byte queue is built in as device 8:
OpenI(8);  OpenO(8);
ChOut(8, ^0);                   \push
ChOut(0, ChIn(8));  CrLf(0);    \pop
ChOut(8, ^1);                   \push
ChOut(8, ^2);                   \push
ChOut(8, ^3);                   \push
ChOut(0, ChIn(8));  CrLf(0);    \pop
ChOut(0, ChIn(8));  CrLf(0);    \pop
ChOut(0, ChIn(8));  CrLf(0);    \pop
]


class Queue{
   var [const] q=List();
   fcn push  { q.append(vm.pasteArgs()) }
   fcn pop   { q.pop(0) }
   fcn empty { q.len()==0 }
}


limite = 2200
s = 3
dim l(limite)
dim ladd(limite * limite * 2)

for x = 1 to limite
    x2 = x * x
    for y = x to limite
        ladd(x2 + y * y) = 1
    next y
next x

for x = 1 to limite
    s1 = s
    s = s + 2
    s2 = s
    for y = x +1 to limite
        if ladd(s1) = 1  l(y) = 1
        s1 = s1 + s2
        s2 = s2 + 2
    next y
next x

for x = 1 to limite
    if l(x) = 0  print str$(x), " ";
next x
print
end


# 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 #
const max_number = 2200;
const max_square = max_number * max_number;
# table of numbers that can be the sum of two squares #
sum_of_two_squares:=Data(max_square+1,Int).fill(0);  # 4 meg byte array
foreach a in ([1..max_number]){
   a2 := a * a;
   foreach b in ([a..max_number]){
      sum2 := ( b * b ) + a2;
      if(sum2 <= max_square) sum_of_two_squares[ sum2 ] = True;  # True-->1
   }
}
# now find d such that d^2 - c^2 is in sum of two squares #
solution:=Data(max_number+1,Int).fill(0);	# another byte array
foreach d in ([1..max_number]){
   d2 := d * d;
   foreach c in ([1..d-1]){
      diff2 := d2 - ( c * c );
      if(sum_of_two_squares[ diff2 ]){ solution[ d ] = True; break; }
   }
}
# print the numbers whose squares are not the sum of three squares #
foreach d in ([1..max_number]){
   if(not solution[ d ]) print(d, " ");
}
println();


Option Base 1
Private Function vtranspose(v As Variant) As Variant
'-- transpose a vector of length m into an mx1 matrix,
'--                       eg {1,2,3} -> {1;2;3}
    vtranspose = WorksheetFunction.Transpose(v)
End Function

Private Function mat_col(a As Variant, col As Integer) As Variant
    Dim res() As Double
    ReDim res(UBound(a))
    For i = col To UBound(a)
        res(i) = a(i, col)
    Next i
    mat_col = res
End Function

Private Function mat_norm(a As Variant) As Double
    mat_norm = Sqr(WorksheetFunction.SumProduct(a, a))
End Function

Private Function mat_ident(n As Integer) As Variant
    mat_ident = WorksheetFunction.Munit(n)
End Function

Private Function sq_div(a As Variant, p As Double) As Variant
    Dim res() As Variant
    ReDim res(UBound(a))
    For i = 1 To UBound(a)
        res(i) = a(i) / p
    Next i
    sq_div = res
End Function

Private Function sq_mul(p As Double, a As Variant) As Variant
    Dim res() As Variant
    ReDim res(UBound(a), UBound(a, 2))
    For i = 1 To UBound(a)
        For j = 1 To UBound(a, 2)
            res(i, j) = p * a(i, j)
        Next j
    Next i
    sq_mul = res
End Function

Private Function sq_sub(x As Variant, y As Variant) As Variant
    Dim res() As Variant
    ReDim res(UBound(x), UBound(x, 2))
    For i = 1 To UBound(x)
        For j = 1 To UBound(x, 2)
            res(i, j) = x(i, j) - y(i, j)
        Next j
    Next i
    sq_sub = res
End Function

Private Function matrix_mul(x As Variant, y As Variant) As Variant
    matrix_mul = WorksheetFunction.MMult(x, y)
End Function

Private Function QRHouseholder(ByVal a As Variant) As Variant
    Dim columns As Integer: columns = UBound(a, 2)
    Dim rows As Integer: rows = UBound(a)
    Dim m As Integer: m = WorksheetFunction.Max(columns, rows)
    Dim n As Integer: n = WorksheetFunction.Min(rows, columns)
    I_ = mat_ident(m)
    Q_ = I_
    Dim q As Variant
    Dim u As Variant, v As Variant, j As Integer
    For j = 1 To WorksheetFunction.Min(m - 1, n)
        u = mat_col(a, j)
        u(j) = u(j) - mat_norm(u)
        v = sq_div(u, mat_norm(u))
        q = sq_sub(I_, sq_mul(2, matrix_mul(vtranspose(v), v)))
        a = matrix_mul(q, a)
        Q_ = matrix_mul(Q_, q)
    Next j

    '-- Get the upper triangular matrix R.
    Dim R() As Variant
    ReDim R(m, n)
    For i = 1 To m 'in Phix this is n
        For j = 1 To n 'in Phix this is i to n. starting at 1 to fill zeroes
            R(i, j) = a(i, j)
        Next j
    Next i
    Dim res(2) As Variant
    res(1) = Q_
    res(2) = R
    QRHouseholder = res
End Function

Private Sub pp(m As Variant)
    For i = 1 To UBound(m)
        For j = 1 To UBound(m, 2)
            Debug.Print Format(m(i, j), "0.#####"),
        Next j
        Debug.Print
    Next i
End Sub
Public Sub main()
    a = [{12, -51,   4; 6, 167, -68; -4,  24, -41;-1,1,0;2,0,3}]
    result = QRHouseholder(a)
    q = result(1)
    r_ = result(2)
    Debug.Print "A"
    pp a
    Debug.Print "Q"
    pp q
    Debug.Print "R"
    pp r_
    Debug.Print "Q * R"
    pp matrix_mul(q, r_)
End Sub


import "/matrix" for Matrix
import "/fmt" for Fmt

var minor = Fn.new { |x, d|
    var nr = x.numRows
    var nc = x.numCols
    var m = Matrix.new(nr, nc)
    for (i in 0...d) m[i, i] = 1
    for (i in d...nr) {
        for (j in d...nc) m[i, j] = x[i, j]
    }
    return m
}

var vmadd = Fn.new { |a, b, s|
    var n = a.count
    var c = List.filled(n, 0)
    for (i in 0...n) c[i] = a[i] + s * b[i]
    return c
}

var vmul = Fn.new { |v|
    var n = v.count
    var x = Matrix.new(n, n)
    for (i in 0...n) {
        for (j in 0...n) x[i, j] = -2 * v[i] * v[j]
    }
    for (i in 0...n) x[i, i] = x[i, i] + 1
    return x
}

var vnorm = Fn.new { |x|
    var n = x.count
    var sum = 0
    for (i in 0...n) sum = sum + x[i] * x[i]
    return sum.sqrt
}

var vdiv = Fn.new { |x, d|
    var n = x.count
    var y = List.filled(n, 0)
    for (i in 0...n) y[i] = x[i] / d
    return y
}

var mcol = Fn.new { |m, c|
    var n = m.numRows
    var v = List.filled(n, 0)
    for (i in 0...n) v[i] = m[i, c]
    return v
}

var householder = Fn.new { |m|
    var nr = m.numRows
    var nc = m.numCols
    var q = List.filled(nr, null)
    var z = m.copy()
    var k = 0
    while (k < nc && k < nr-1) {
       var e = List.filled(nr, 0)
       z = minor.call(z, k)
       var x = mcol.call(z, k)
       var a = vnorm.call(x)
       if (m[k, k] > 0) a = -a
       for (i in 0...nr) e[i] = (i == k) ? 1 : 0
       e = vmadd.call(x, e, a)
       e = vdiv.call(e, vnorm.call(e))
       q[k] = vmul.call(e)
       z = q[k] * z
       k = k + 1
    }
    var Q = q[0]
    var R = q[0] * m
    var i = 1
    while (i < nc && i < nr-1) {
        Q = q[i] * Q
        i = i + 1
    }
    R = Q * m
    Q = Q.transpose
    return [Q, R]
}

var inp = [
    [12, -51,   4],
	[ 6, 167, -68],
	[-4,  24, -41],
	[-1,   1,   0],
	[ 2,   0,   3]
]
var x = Matrix.new(inp)
var res = householder.call(x)
var Q = res[0]
var R = res[1]
var m = Q * R
System.print("Q:")
Fmt.mprint(Q, 8, 3)
System.print("\nR:")
Fmt.mprint(R, 8, 3)
System.print("\nQ * R:")
Fmt.mprint(m, 8, 3)


var [const] GSL=Import("zklGSL");	// libGSL (GNU Scientific Library)
A:=GSL.Matrix(3,3).set(12.0, -51.0,   4.0,
			6.0, 167.0, -68.0,
			4.0,  24.0, -41.0);
Q,R:=A.QRDecomp();
println("Q:\n",Q.format());
println("R:\n",R.format());
println("Q*R:\n",(Q*R).format());


T XorShiftStar
   UInt64 state

   F seed(seed_state)
      .state = seed_state

   F next_int() -> UInt32
      V x = .state
      x (+)= x >> 12
      x (+)= x << 25
      x (+)= x >> 27
      .state = x
      R (x * 2545'F491'4F6C'DD1D) >> 32

   F next_float()
      R Float(.next_int()) / 2.0^32

V random_gen = XorShiftStar()
random_gen.seed(1234567)
L 5
   print(random_gen.next_int())

random_gen.seed(987654321)
V hist = Dict(0.<5, i -> (i, 0))
L 100'000
   hist[Int(random_gen.next_float() * 5)]++
print(hist)


with Interfaces;  use Interfaces;
with Ada.Text_IO; use Ada.Text_IO;

procedure Main is
   const : constant Unsigned_64 := 16#2545_F491_4F6C_DD1D#;
   state : Unsigned_64          := 0;
   Unseeded_Error : exception;

   procedure seed (num : Unsigned_64) is
   begin
      state := num;
   end seed;

   function Next_Int return Unsigned_32 is
      x : Unsigned_64 := state;
   begin
      if state = 0 then
         raise Unseeded_Error;
      end if;

      x     := x xor (x / 2**12);
      x     := x xor (x * 2**25);
      x     := x xor (x / 2**27);
      state := x;
      return Unsigned_32 ((x * const) / 2**32);
   end Next_Int;

   function Next_Float return Long_Float is
   begin
      return Long_Float (Next_Int) / 2.0**32;
   end Next_Float;

   counts : array (0 .. 4) of Natural := (others => 0);
   J      : Natural;
begin
   seed (1_234_567);
   for I in 1 .. 5 loop
      Put_Line (Unsigned_32'Image (Next_Int));
   end loop;

   seed (987_654_321);
   for I in 1 .. 100_000 loop
      J          := Natural (Long_Float'Floor (Next_Float * 5.0));
      counts (J) := counts (J) + 1;
   end loop;

   New_Line;
   for I in counts'Range loop
      Put_Line (I'Image & " :" & counts (I)'Image);
   end loop;

end Main;


BEGIN # generate some pseudo random numbers using Xorshift star #
    # note that although LONG INT is 64 bits in Algol 68G, LONG BITS is longer than 64 bits #
    LONG BITS state;
    LONG INT  const      = ABS LONG 16r2545f4914f6cdd1d;
    LONG INT  one shl 32 = ABS ( LONG 16r1 SHL 32 );
    # sets the state to the specified seed value #
    PROC seed = ( LONG INT num )VOID: state := BIN num;
    # XOR and assign convenience operator #
    PRIO XORAB = 1;
    OP   XORAB = ( REF LONG BITS x, LONG BITS v )REF LONG BITS: x := ( x XOR v ) AND LONG 16rffffffffffffffff;
    # gets the next pseudo random integer #
    PROC next int = LONG INT:
         BEGIN
            LONG BITS x := state;
            x XORAB ( x SHR 12 );
            x XORAB ( x SHL 25 );
            x XORAB ( x SHR 27 );
            state := x;
            SHORTEN ABS ( 16rffffffff AND BIN ( ABS x * LENG const ) SHR 32 )
         END # next int # ;
    # gets the next pseudo random real #
    PROC next float = LONG REAL: next int / one shl 32;
    BEGIN # task test cases #
        seed( 1234567 );
        print( ( whole( next int, 0 ), newline ) ); # 3540625527 #
        print( ( whole( next int, 0 ), newline ) ); # 2750739987 #
        print( ( whole( next int, 0 ), newline ) ); # 4037983143 #
        print( ( whole( next int, 0 ), newline ) ); # 1993361440 #
        print( ( whole( next int, 0 ), newline ) ); # 3809424708 #
        # count the number of occurances of 0..4 in a sequence of pseudo random reals scaled to be in [0..5) #
        seed( 987654321 );
        [ 0 : 4 ]INT counts; FOR i FROM LWB counts TO UPB counts DO counts[ i ] := 0 OD;
        TO 100 000 DO counts[ SHORTEN ENTIER ( next float * 5 ) ] +:= 1 OD;
        FOR i FROM LWB counts TO UPB counts DO
            print( ( whole( i, -2 ), ": ", whole( counts[ i ], -6 ) ) )
        OD;
        print( ( newline ) )
    END
END


T Splitmix64
   UInt64 state

   F seed(seed_state)
      .state = seed_state

   F next_int()
      .state += 9E37'79B9'7F4A'7C15
      V z = .state
      z = (z (+) (z >> 30)) * BF58'476D'1CE4'E5B9
      z = (z (+) (z >> 27)) * 94D0'49BB'1331'11EB
      R z (+) (z >> 31)

   F next_float()
      R Float(.next_int()) / 2.0^64

V random_gen = Splitmix64()
random_gen.seed(1234567)
L 5
   print(random_gen.next_int())

random_gen.seed(987654321)
V hist = Dict(0.<5, i -> (i, 0))
L 100'000
   hist[Int(random_gen.next_float() * 5)]++
print(hist)


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

static uint64_t state;
static const uint64_t STATE_MAGIC = 0x2545F4914F6CDD1D;

void seed(uint64_t num) {
    state = num;
}

uint32_t next_int() {
    uint64_t x;
    uint32_t answer;

    x = state;
    x = x ^ (x >> 12);
    x = x ^ (x << 25);
    x = x ^ (x >> 27);
    state = x;
    answer = ((x * STATE_MAGIC) >> 32);

    return answer;
}

float next_float() {
    return (float)next_int() / (1LL << 32);
}

int main() {
    int counts[5] = { 0, 0, 0, 0, 0 };
    int i;

    seed(1234567);
    printf("%u\n", next_int());
    printf("%u\n", next_int());
    printf("%u\n", next_int());
    printf("%u\n", next_int());
    printf("%u\n", next_int());
    printf("\n");

    seed(987654321);
    for (i = 0; i < 100000; i++) {
        int j = (int)floor(next_float() * 5.0);
        counts[j]++;
    }
    for (i = 0; i < 5; i++) {
        printf("%d: %d\n", i, counts[i]);
    }

    return 0;
}


with Interfaces; use Interfaces;

package Random_Splitmix64 is

   function next_Int return Unsigned_64;
   function next_float return Float;
   procedure Set_State (Seed : in Unsigned_64);
end Random_Splitmix64;


BEGIN # generate some pseudo random numbers using Splitmix64 #
    # note that although LONG INT is 64 bits in Algol 68G, LONG BITS is longer than 64 bits #
    LONG BITS mask 64    = LONG 16rffffffffffffffff;
    LONG BITS state     := 16r1234567;
    LONG INT  one shl 64 = ABS ( LONG 16r1 SHL 64 );
    # sets the state to the specified seed value #
    PROC seed = ( LONG INT num )VOID: state := BIN num;
    # XOR and assign convenience operator #
    PRIO XORAB = 1;
    OP   XORAB = ( REF LONG BITS x, LONG BITS v )REF LONG BITS:
         x := ( x XOR v ) AND mask 64;
    # add a LONG BITS value to a LONG BITS #
    OP   +:= = ( REF LONG BITS r, LONG BITS v )REF LONG BITS:
         r := SHORTEN ( BIN ( LENG ABS r + LENG ABS v ) AND mask 64 );
    # multiplies a LONG BITS value by a LONG BITS value #
    OP   *:= = ( REF LONG BITS r, LONG BITS v )REF LONG BITS:
         r := SHORTEN ( BIN ( ABS LENG r * LENG ABS v ) AND mask 64 );
    # gets the next pseudo random integer #
    PROC next int = LONG INT:
         BEGIN
            state +:= LONG 16r9e3779b97f4a7c15;
            LONG BITS z := state;
            z XORAB ( z SHR 30 );
            z *:= LONG 16rbf58476d1ce4e5b9;
            z XORAB ( z SHR 27 );
            z *:= LONG 16r94d049bb133111eb;
            z XORAB ( z SHR 31 );
            ABS z
         END # next int # ;
    # gets the next pseudo random real #
    PROC next float = LONG REAL: next int / one shl 64;
    BEGIN # task test cases #
        seed( 1234567 );
        print( ( whole( next int, 0 ), newline ) ); #  6457827717110365317 #
        print( ( whole( next int, 0 ), newline ) ); #  3203168211198807973 #
        print( ( whole( next int, 0 ), newline ) ); #  9817491932198370423 #
        print( ( whole( next int, 0 ), newline ) ); #  4593380528125082431 #
        print( ( whole( next int, 0 ), newline ) ); # 16408922859458223821 #
        # count the number of occurances of 0..4 in a sequence of pseudo random reals scaled to be in [0..5) #
        seed( 987654321 );
        [ 0 : 4 ]INT counts; FOR i FROM LWB counts TO UPB counts DO counts[ i ] := 0 OD;
        TO 100 000 DO counts[ SHORTEN ENTIER ( next float * 5 ) ] +:= 1 OD;
        FOR i FROM LWB counts TO UPB counts DO
            print( ( whole( i, -2 ), ": ", whole( counts[ i ], -6 ) ) )
        OD;
        print( ( newline ) )
    END
END


#include <array>
#include <cstdint>
#include <iostream>

class XorShiftStar {
private:
    const uint64_t MAGIC = 0x2545F4914F6CDD1D;
    uint64_t state;
public:
    void seed(uint64_t num) {
        state = num;
    }

    uint32_t next_int() {
        uint64_t x;
        uint32_t answer;

        x = state;
        x = x ^ (x >> 12);
        x = x ^ (x << 25);
        x = x ^ (x >> 27);
        state = x;
        answer = ((x * MAGIC) >> 32);

        return answer;
    }

    float next_float() {
        return (float)next_int() / (1LL << 32);
    }
};

int main() {
    auto rng = new XorShiftStar();
    rng->seed(1234567);
    std::cout << rng->next_int() << '\n';
    std::cout << rng->next_int() << '\n';
    std::cout << rng->next_int() << '\n';
    std::cout << rng->next_int() << '\n';
    std::cout << rng->next_int() << '\n';
    std::cout << '\n';

    std::array<int, 5> counts = { 0, 0, 0, 0, 0 };
    rng->seed(987654321);
    for (int i = 0; i < 100000; i++) {
        int j = (int)floor(rng->next_float() * 5.0);
        counts[j]++;
    }
    for (size_t i = 0; i < counts.size(); i++) {
        std::cout << i << ": " << counts[i] << '\n';
    }

    return 0;
}


/*  Written in 2015 by Sebastiano Vigna ([email protected])

To the extent possible under law, the author has dedicated all copyright
and related and neighboring rights to this software to the public domain
worldwide. This software is distributed without any warranty.

See <http://creativecommons.org/publicdomain/zero/1.0/>. */

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

/* This is a fixed-increment version of Java 8's SplittableRandom generator
   See http://dx.doi.org/10.1145/2714064.2660195 and
   http://docs.oracle.com/javase/8/docs/api/java/util/SplittableRandom.html

   It is a very fast generator passing BigCrush, and it can be useful if
   for some reason you absolutely want 64 bits of state. */

static uint64_t x; /* The state can be seeded with any value. */

uint64_t next() {
	uint64_t z = (x += 0x9e3779b97f4a7c15);
	z = (z ^ (z >> 30)) * 0xbf58476d1ce4e5b9;
	z = (z ^ (z >> 27)) * 0x94d049bb133111eb;
	return z ^ (z >> 31);
}

double next_float() {
    return next() / pow(2.0, 64);
}

int main() {
    int i, j;
    x = 1234567;
    for(i = 0; i < 5; ++i)
        printf("%llu\n", next()); /* needed to use %lu verb for GCC 7.5.0-3 */
    x = 987654321;
    int vec5[5] = {0, 0, 0, 0, 0};
    for(i = 0; i < 100000; ++i) {
        j = next_float() * 5.0;
        vec5[j] += 1;
    }
    for(i = 0; i < 5; ++i)
        printf("%d: %d  ", i, vec5[i]);
}


USING: io kernel math math.bitwise math.functions
math.statistics namespaces prettyprint sequences ;

SYMBOL: state

: seed ( n -- ) 64 bits state set ;

: next-int ( -- n )
    0x9e3779b97f4a7c15 state [ + 64 bits ] change
    state get -30 0xbf58476d1ce4e5b9 -27 0x94d049bb133111eb -31 1
    [ [ dupd shift bitxor ] dip * 64 bits ] [email protected] ;

: next-float ( -- x ) next-int 64 2^ /f ;

! Test next-int
"Seed: 1234567; first five integer values" print
1234567 seed 5 [ next-int . ] times nl

! Test next-float
"Seed: 987654321; first 100,000 float values histogram" print
987654321 seed 100,000 [ next-float 5 * >integer ] replicate
histogram .


variable rnd-state

: rnd-base-op ( z factor shift -- u ) 2 pick swap rshift rot xor * ;

: rnd-next ( -- u )
  $9e3779b97f4a7c15 rnd-state +!
  rnd-state @
  $bf58476d1ce4e5b9 #30 rnd-base-op
  $94d049bb133111eb #27 rnd-base-op
  #1 #31 rnd-base-op
;

#1234567 rnd-state !
cr
rnd-next u. cr
rnd-next u. cr
rnd-next u. cr
rnd-next u. cr
rnd-next u. cr

: rnd-next-float ( -- f )
  rnd-next 0 d>f 0 1 d>f f/
;

create counts 0 , 0 , 0 , 0 , 0 ,
: counts-fill
  #987654321 rnd-state !
  100000 0 do
    rnd-next-float 5.0e0 f* f>d drop cells counts + dup @ 1+ swap !
  loop
;
: counts-disp
  5 0 do
    cr i . ': emit bl emit
    counts i cells + @ .
  loop cr
;

counts-fill counts-disp


import std.math;
import std.stdio;

class XorShiftStar {
    private immutable MAGIC = 0x2545F4914F6CDD1D;
    private ulong state;

    public void seed(ulong num) {
        state = num;
    }

    public uint nextInt() {
        ulong x;
        uint answer;

        x = state;
        x = x ^ (x >> 12);
        x = x ^ (x << 25);
        x = x ^ (x >> 27);
        state = x;
        answer = ((x * MAGIC) >> 32);

        return answer;
    }

    public float nextFloat() {
        return cast(float) nextInt() / (1L << 32);
    }
}

void main() {
    auto rng = new XorShiftStar();
    rng.seed(1234567);
    writeln(rng.nextInt);
    writeln(rng.nextInt);
    writeln(rng.nextInt);
    writeln(rng.nextInt);
    writeln(rng.nextInt);
    writeln;

    int[5] counts;
    rng.seed(987654321);
    foreach (_; 0 .. 100_000) {
        auto j = cast(int) floor(rng.nextFloat * 5.0);
        counts[j]++;
    }
    foreach (i, v; counts) {
        writeln(i, ": ", v);
    }
}


program Xorshift_star;

{$APPTYPE CONSOLE}

uses
  System.SysUtils,
  System.Math;

type
  TXorshiftStar = record
  private
    state: uint64;
    const
      k = $2545F4914F6CDD1D;
  public
    constructor Create(aState: uint64);
    procedure Seed(aState: uint64);
    function NextInt: uint32;
    function NextFloat: Extended;
  end;

{ TXorshiftStar }

constructor TXorshiftStar.Create(aState: uint64);
begin
  Seed(aState);
end;

function TXorshiftStar.NextFloat: Extended;
begin
  Result := NextInt() / $100000000;
end;

function TXorshiftStar.NextInt: uint32;
var
  x: UInt64;
begin
  x := state;
  x := x xor (x shr 12);
  x := x xor (x shl 25);
  x := x xor (x shr 27);
  state := x;
  Result := uint32((x * k) shr 32);
end;

procedure TXorshiftStar.Seed(aState: uint64);
begin
  state := aState;
end;

begin
  var randomGen := TXorshiftStar.Create(1234567);

  for var i := 0 to 4 do
    writeln(randomGen.NextInt);

  var counts := [0, 0, 0, 0, 0];
  randomGen.seed(987654321);

  for var i := 1 to 100000 do
  begin
    var j := Floor(randomGen.nextFloat() * 5);
    inc(counts[j]);
  end;

  writeln(#10'The counts for 100,000 repetitions are:');

  for var i := 0 to 4 do
    writeln(format(' %d : %d', [i, counts[i]]));

  {$IFNDEF UNIX} Readln; {$ENDIF}
end.


// Pure F# Implementation of SplitMix64
let a: uint64 = 0x9e3779b97f4a7c15UL

let nextInt (state: uint64) =
    let newstate = state + (0x9e3779b97f4a7c15UL)
    let rand = newstate
    let rand = (rand ^^^ (rand >>> 30)) * 0xbf58476d1ce4e5b9UL
    let rand = (rand ^^^ (rand >>> 27)) * 0x94d049bb133111ebUL
    let rand = rand ^^^ (rand >>> 31)
    (rand, newstate)

let nextFloat (state: uint64) =
    let (rand, newState) = nextInt state
    let randf = (rand / (1UL <<< 64)) |> float
    (randf, newState)

[<EntryPoint>]
let main argv =
    let state = 1234567UL
    let (first, state) = nextInt state
    let (second, state) = nextInt state
    let (third, state) = nextInt state
    let (fourth, state) = nextInt state
    let (fifth, state) = nextInt state
    printfn "%i" first
    printfn "%i" second
    printfn "%i" third
    printfn "%i" fourth
    printfn "%i" fifth
    0


package main

import (
    "fmt"
    "math"
)

type Splitmix64 struct{ state uint64 }

func Splitmix64New(state uint64) *Splitmix64 { return &Splitmix64{state} }

func (sm64 *Splitmix64) nextInt() uint64 {
    sm64.state += 0x9e3779b97f4a7c15
    z := sm64.state
    z = (z ^ (z >> 30)) * 0xbf58476d1ce4e5b9
    z = (z ^ (z >> 27)) * 0x94d049bb133111eb
    return z ^ (z >> 31)
}

func (sm64 *Splitmix64) nextFloat() float64 {
    return float64(sm64.nextInt()) / (1 << 64)
}

func main() {
    randomGen := Splitmix64New(1234567)
    for i := 0; i < 5; i++ {
        fmt.Println(randomGen.nextInt())
    }

    var counts [5]int
    randomGen = Splitmix64New(987654321)
    for i := 0; i < 1e5; i++ {
        j := int(math.Floor(randomGen.nextFloat() * 5))
        counts[j]++
    }
    fmt.Println("\nThe counts for 100,000 repetitions are:")
    for i := 0; i < 5; i++ {
        fmt.Printf("  %d : %d\n", i, counts[i])
    }
}


// Xorshift star. Nigel Galloway: August 14th., 2020
let fN=(fun(n:uint64)->n^^^(n>>>12))>>(fun n->n^^^(n<<<25))>>(fun n->n^^^(n>>>27))
let Xstar32=Seq.unfold(fun n->let n=fN n in Some(uint32((n*0x2545F4914F6CDD1DUL)>>>32),n))
let XstarF n=Xstar32 n|>Seq.map(fun n->(float n)/4294967296.0)


USING: accessors kernel literals math math.statistics
prettyprint sequences ;

CONSTANT: mask64 $[ 1 64 shift 1 - ]
CONSTANT: mask32 $[ 1 32 shift 1 - ]
CONSTANT: const 0x2545F4914F6CDD1D

! Restrict seed value to positive integers.
PREDICATE: positive < integer 0 > ;
ERROR: seed-nonpositive seed ;

TUPLE: xorshift* { state positive initial: 1 } ;

: <xorshift*> ( seed -- xorshift* )
    dup positive? [ seed-nonpositive ] unless
    mask64 bitand xorshift* boa ;

: twiddle ( m n -- n ) dupd shift bitxor mask64 bitand ;

: next-int ( obj -- n )
    dup state>> -12 twiddle 25 twiddle -27 twiddle tuck swap
    state<< const * mask64 bitand -32 shift mask32 bitand ;

: next-float ( obj -- x ) next-int 1 32 shift /f ;

! ---=== Task ===---
1234567 <xorshift*> 5 [ dup next-int . ] times

987654321 >>state
100,000 [ dup next-float 5 * >integer ] replicate nip
histogram .


package main

import (
    "fmt"
    "math"
)

const CONST = 0x2545F4914F6CDD1D

type XorshiftStar struct{ state uint64 }

func XorshiftStarNew(state uint64) *XorshiftStar { return &XorshiftStar{state} }

func (xor *XorshiftStar) seed(state uint64) { xor.state = state }

func (xor *XorshiftStar) nextInt() uint32 {
    x := xor.state
    x = x ^ (x >> 12)
    x = x ^ (x << 25)
    x = x ^ (x >> 27)
    xor.state = x
    return uint32((x * CONST) >> 32)
}

func (xor *XorshiftStar) nextFloat() float64 {
    return float64(xor.nextInt()) / (1 << 32)
}

func main() {
    randomGen := XorshiftStarNew(1234567)
    for i := 0; i < 5; i++ {
        fmt.Println(randomGen.nextInt())
    }

    var counts [5]int
    randomGen.seed(987654321)
    for i := 0; i < 1e5; i++ {
        j := int(math.Floor(randomGen.nextFloat() * 5))
        counts[j]++
    }
    fmt.Println("\nThe counts for 100,000 repetitions are:")
    for i := 0; i < 5; i++ {
        fmt.Printf("  %d : %d\n", i, counts[i])
    }
}


import Data.Bits
import Data.Word
import Data.List

next :: Word64 -> (Word64, Word64)
next state = f4 $ state + 0x9e3779b97f4a7c15
  where
    f1 z = (z `xor` (z `shiftR` 30)) * 0xbf58476d1ce4e5b9
    f2 z = (z `xor` (z `shiftR` 27)) * 0x94d049bb133111eb
    f3 z = z `xor` (z `shiftR` 31)
    f4 s = ((f3 . f2 . f1) s, s)

randoms = unfoldr (pure . next)

toFloat n = fromIntegral n / (2^64 - 1)


const C1 = 0x9e3779b97f4a7c15
const C2 = 0xbf58476d1ce4e5b9
const C3 = 0x94d049bb133111eb

mutable struct Splitmix64
    state::UInt
end

""" return random int between 0 and 2**64 """
function next_int(smx::Splitmix64)
    z = smx.state = smx.state + C1
    z = (z ⊻ (z >> 30)) * C2
    z = (z ⊻ (z >> 27)) * C3
    return z ⊻ (z >> 31)
end

""" return random float between 0 and 1 """
next_float(smx::Splitmix64) = next_int(smx) / one(Int128) << 64

function testSplitmix64()
    random_gen = Splitmix64(1234567)
    for i in 1:5
        println(next_int(random_gen))
    end

    random_gen = Splitmix64(987654321)
    hist = fill(0, 5)
    for _ in 1:100_000
        hist[Int(floor(next_float(random_gen) * 5)) + 1] += 1
    end
    foreach(n -> print(n - 1, ": ", hist[n], "  "), 1:5)
end

testSplitmix64()


ClearAll[BitShiftLevelUint, MultiplyUint, GenerateRandomNumbers]
BitShiftLevelUint[z_, n_] := BitShiftRight[z, n]
MultiplyUint[z_, n_] := Mod[z n, 2^64]
GenerateRandomNumbers[st_, n_] := Module[{state = st},
  Table[
   state += 16^^9e3779b97f4a7c15;
   state = Mod[state, 2^64];
   z = state;
   z = MultiplyUint[BitXor[z, BitShiftLevelUint[z, 30]], 16^^bf58476d1ce4e5b9];
   z = MultiplyUint[BitXor[z, BitShiftLevelUint[z, 27]], 16^^94d049bb133111eb];
   Mod[BitXor[z, BitShiftLevelUint[z, 31]], 2^64]
   ,
   {n}
   ]
  ]
GenerateRandomNumbers[1234567, 5]
nums = GenerateRandomNumbers[987654321, 10^5];
KeySort[Counts[Floor[5 nums/N[2^64]]]]


import math, sequtils, strutils

const Two64 = 2.0^64

type Splitmix64 = object
  state: uint64

func initSplitmix64(seed: uint64): Splitmix64 =
  ## Initialize a Splitmiax64 PRNG.
  Splitmix64(state: seed)

func nextInt(r: var Splitmix64): uint64 =
  ## Return the next pseudorandom integer (actually a uint64 value).
  r.state += 0x9e3779b97f4a7c15u
  var z = r.state
  z = (z xor z shr 30) * 0xbf58476d1ce4e5b9u
  z = (z xor z shr 27) * 0x94d049bb133111ebu
  result = z xor z shr 31

func nextFloat(r: var Splitmix64): float =
  ## Retunr the next pseudorandom float (between 0.0 and 1.0 excluded).
  r.nextInt().float / Two64

when isMainModule:

  echo "Seed = 1234567:"
  var prng = initSplitmix64(1234567)
  for i in 1..5:
    echo i, ": ", ($prng.nextInt).align(20)

  echo "\nSeed = 987654321:"
  var counts: array[0..4, int]
  prng = initSplitmix64(987654321)
  for _ in 1..100_000:
    inc counts[int(prng.nextFloat * 5)]
  echo toSeq(counts.pairs).mapIt(($it[0]) & ": " & ($it[1])).join(", "