[setup]
    nomainwin

    speed=50

    prompt "Number of balls to drop: ";cycleMax
    cycleMax=abs(int(cycleMax))

'create window
    WindowWidth=400
    WindowHeight=470
    UpperLeftX=1
    UpperLeftY=1
    graphicbox #1.gb, 10, 410,370,25
    open "Galton Machine" for graphics_nf_nsb as #1
    #1 "trapclose [q];down;fill black;flush"
    #1.gb "font courier_new 12"

'Create graphical sprites
    #1 "getbmp bg 1 1 400 600"
    #1 "place 0 0; color white;backcolor white;boxfilled 17 17;place 8 8;color black;backcolor black;circlefilled 8;"
    #1 "place 8 25;color white;backcolor white;circlefilled 8;"
    #1 "getbmp ball 0 0 17 34"
    #1 "place 8 25;color red;backcolor red;circlefilled 8;"
    #1 "getbmp pin 0 0 17 34"
    #1 "background bg"

'add sprites to program
    for pinCount = 1 to 28
        #1 "addsprite pin";pinCount;" pin;spriteround pin";pinCount
    next pinCount

    for ballCount = 1 to 7
        #1 "addsprite ball";ballCount;" ball;spriteround ball";ballCount
    next ballCount

'place pins on page
    for y = 1 to 7
        for x = 1 to y
            pin=pin+1
            xp=200-x*50+y*25
            yp=y*35+100
            #1 "spritexy pin";pin;" ";xp;" ";yp
            #1 "drawsprites"
        next x
    next y

'set balls in motion
    for a = 1 to 7
        #1 "spritexy ball";a;" 174 ";a*60-350
        #1 "spritemovexy ball";a;" 0 5"
    next a

[start] 'update every 50ms - lower number means faster updates
    timer speed, [move]
    wait

[move] 'cycle through the sprites to check for contact with pins or dropping off board
    #1 "drawsprites"
    for ballNum = 1 to 7
        gosub [checkCollide]
    next ballNum
    timer speed, [move]
    wait

[checkCollide] 'check for contact with pins or dropping off board
    timer 0
    #1 "spritexy? ball";ballNum;" x y" 'get current ball position
    #1 "spritecollides ball";ballNum;" hits$" 'collect any collisions
    if hits$<>"" then 'any collisions? if so...
        direction = rnd(1)
        'randomly bounce either left or right
        if direction >0.4999999 then #1 "spritexy ball";ballNum;" ";x+25;" ";y else #1 "spritexy ball";ballNum;" ";x-25;" ";y
        #1 "spritemovexy ball";ballNum;" 0 5"'set ball in motion again
    end if
    #1 "spritexy? ball";ballNum;" x y" 'get current ball position
    if y > 400 then 'if ball has dropped off board, then...
        select case 'figure out which slot it has landed in and increment the counter for that slot
            case x<49
                slot(1)=slot(1)+1
            case x=49
                slot(2)=slot(2)+1
            case x=99
                slot(3)=slot(3)+1
            case x=149
                slot(4)=slot(4)+1
            case x=199
                slot(5)=slot(5)+1
            case x=249
                slot(6)=slot(6)+1
            case x=299
                slot(7)=slot(7)+1
            case x>299
                slot(8)=slot(8)+1
        end select
        for a = 1 to 8 'write the slot counts in the small graphic box
            update$="place "+str$((a-1)*48+1)+" 20;\"+str$(slot(a))
            #1.gb, update$
        next a
        #1 "spritexy ball";ballNum;" 174 ";0-10 'reposition the sprite just off the top of the screen
        #1 "spritemovexy ball";ballNum;" 0 5" 'set the ball in motion again
        cycles = cycles + 1 'increment the fallen ball count
        if cycles >= cycleMax then
            timer 0 'stop animation
            'make the visible balls go away
            for a = 1 to 7
                #1 "spritexy ball";a;" 174 700"
                #1 "spritemovexy ball";a;" 0 0"
            next a
            #1 "drawsprites"
            notice "Complete"
            wait
        end if
    end if
return

[q]
    close #1
    'It is IMPORTANT to unload the bitmaps and clear memory
    unloadbmp "pin"
    unloadbmp "ball"
    unloadbmp "bg"
    end


Bitmap.render = function(self)
  for y = 1, self.height do
    print(table.concat(self.pixels[y], " "))
  end
end

-- globals (tweak here as desired)
math.randomseed(os.time())
local W, H, MIDX = 15, 40, 7
local bitmap = Bitmap(W, H)
local AIR, PIN, BALL, FLOOR = ".", "▲", "☻", "■"
local nballs, balls = 60, {}
local frame, showEveryFrame = 1, false

-- the game board:
bitmap:clear(AIR)
for row = 1, 7 do
  for col = 0, row-1 do
    bitmap:set(MIDX-row+col*2+1, 1+row*2, PIN)
  end
end
for col = 0, W-1 do
  bitmap:set(col, H-1, FLOOR)
end

-- ball class
Ball = {
  new = function(self, x, y, bitmap)
    local instance = setmetatable({ x=x, y=y, bitmap=bitmap, alive=true }, self)
    return instance
  end,
  update = function(self)
    if not self.alive then return end
    self.bitmap:set(self.x, self.y, AIR)
    local newx, newy = self.x, self.y+1
    local below = self.bitmap:get(newx, newy)
    if below==PIN then
      newx = newx + (math.random(2)-1)*2-1
    end
    local there = self.bitmap:get(newx, newy)
    if there==AIR then
      self.x, self.y = newx, newy
    else
      self.alive = false
    end
    self.bitmap:set(self.x, self.y, BALL)
  end,
}
Ball.__index = Ball
setmetatable(Ball, { __call = function (t, ...) return t:new(...) end })

-- simulation:
local function spawn()
  if nballs > 0 then
    balls[#balls+1] = Ball(MIDX, 0, bitmap)
    nballs = nballs - 1
  end
end

spawn()
while #balls > 0 do
  if frame%2==0 then spawn() end
  alive = {}
  for _,ball in ipairs(balls) do
    ball:update()
    if ball.alive then alive[#alive+1]=ball end
  end
  balls = alive
  if frame%50==0 or #alive==0 or showEveryFrame then
    print("FRAME "..frame..":")
    bitmap:render()
  end
  frame = frame + 1
end


ClearAll[MakePathFunction]
MakePathFunction[{path_, acumpath_}] :=
 Module[{f1, f2, f3, pf, n = Length[path]},
  f1 = MapThread[{#1/2, #2 + 0.5 < z <= #2 + 1} &, {acumpath,
     n - Range[n + 1]}];
  f2 = MapThread[{#1/2 + #2 Sqrt[1/4 - (z - #3)^2], #3 <
       z <= #3 + 1/2} &, {acumpath // Most, path, n - Range[n]}];
  f3 = {{acumpath[[-1]]/2, z <= 0}};
  pf = Piecewise[Evaluate[Join[f1, f2, f3]], 0];
  pf
  ]
MakeScene[pfs_List, zfinals_List, n_Integer, t_] :=
 Module[{durations, accumduration, if, part, fixed, relt},
  durations = n - zfinals;
  accumduration = Accumulate[Prepend[durations, 0]];
  if = Interpolation[{accumduration, Range[Length[zfinals] + 1]} //
     Transpose, InterpolationOrder -> 1];
  part = Floor[if[t]];
  If[part > 0,
   fixed = Table[{pfs[[i]], z} /. z -> zfinals[[i]], {i, part - 1}];
   ,
   fixed = {};
   ];
  relt = t - accumduration[[part]];
  relt = n - relt;
  Append[fixed, {pfs[[part]] /. z -> relt, relt}]
  ]
SeedRandom[1234];
n = 6;
m = 150;
r = 0.25; (* fixed *)
dots =
 [email protected][{# - i/2 - 1/2, n - i} & /@ Range[i], {i, n}];
g = Graphics[Disk[#, r] & /@ dots, Axes -> True];

paths = RandomChoice[{-1, 1}, {m, n}];
paths = {#, Accumulate[Prepend[#, 0]]} & /@ paths;
xfinals = paths[[All, 2, -1]];
types = DeleteDuplicates[xfinals];
zfinals = ConstantArray[0, Length[paths]];
Do[
  pos = Flatten[Position[xfinals, t]];
  zfinals[[pos]] += 0.5 Range[Length[pos]];
  ,
  {t, types}
  ];
max = Max[zfinals] + 1;
zfinals -= max;
pfs = MakePathFunction /@ paths;
Manipulate[
 Graphics[{Disk[#, r] & /@ dots, Red,
   Disk[#, r] & /@ MakeScene[pfs, zfinals, n, t]},
  PlotRange -> {{-n, n}, {Min[zfinals] - 1, n + 2}},
  ImageSize -> 150], {t, 0, Total[n - zfinals] - 0.001}]


import random, strutils

const
  BoxW = 41         # Galton box width.
  BoxH = 37         # Galton box height.
  PinsBaseW = 19    # Pins triangle base.
  NMaxBalls = 55    # Number of balls.

const CenterH = PinsBaseW + (BoxW - (PinsBaseW * 2 - 1)) div 2 - 1

type

  Cell = enum
    cEmpty = " "
    cBall = "o"
    cWall = "|"
    cCorner = "+"
    cFloor = "-"
    cPin = "."

  # Galton box. Will be printed upside-down.
  Box = array[BoxH, array[BoxW, Cell]]

  Ball = ref object
    x, y: int

func initBox(): Box =

  # Set ceiling and floor.
  result[0][0] = cCorner
  result[0][^1] = cCorner
  for i in 1..(BoxW - 2):
    result[0][i] = cFloor
  result[^1] = result[0]

  # Set walls.
  for i in 1..(BoxH - 2):
    result[i][0] = cWall
    result[i][^1] = cWall

  # Set rest to Empty initially.
  for i in 1..(BoxH - 2):
    for j in 1..(BoxW - 2):
      result[i][j] = cEmpty

  # Set pins.
  for nPins in 1..PinsBaseW:
    for p in 0..<nPins:
      result[BoxH - 2 - nPins][CenterH + 1 - nPins + p * 2] = cPin

func newBall(box: var Box; x, y: int): Ball =

  doAssert box[y][x] == cEmpty, "Tried to create a new ball in a non-empty cell"
  result = Ball(x: x, y: y)
  box[y][x] = cBall

proc doStep(box: var Box; b: Ball) =

  if b.y <= 0:
    return    # Reached the bottom of the box.

  case box[b.y-1][b.x]

  of cEmpty:
    box[b.y][b.x] = cEmpty
    dec b.y
    box[b.y][b.x] = cBall

  of cPin:
    box[b.y][b.x] = cEmpty
    dec b.y
    if box[b.y][b.x-1] == cEmpty and box[b.y][b.x+1] == cEmpty:
      inc b.x, 2 * rand(1) - 1
    elif box[b.y][b.x-1] == cEmpty:
      inc b.x
    else:
      dec b.x
    box[b.y][b.x] = cBall

  else:
    # It's frozen - it always piles on other balls.
    discard

proc draw(box: Box) =
  for r in countdown(BoxH - 1, 0):
    echo box[r].join()

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

randomize()
var box = initBox()
var balls: seq[Ball]

for i in 0..<(NMaxBalls + BoxH):

  echo "Step ", i, ':'
  if i < NMaxBalls:
    balls.add box.newBall(CenterH, BoxH - 2)
  box.draw()

  # Next step for the simulation.
  # Frozen balls are kept in balls slice for simplicity.
  for ball in balls:
    box.doStep(ball)


use strict;
use warnings;

use List::Util 'any';
use Time::HiRes qw(sleep);
use List::AllUtils <pairwise pairs>;

use utf8;
binmode STDOUT, ':utf8';

my $coins      = shift || 100;
my $peg_lines  = shift || 13;
my $row_count  = $peg_lines;
my $peg        = '^';
my @coin_icons = ("\N{UPPER HALF BLOCK}", "\N{LOWER HALF BLOCK}");

my @coins = (undef) x (3 + $row_count + 4);
my @stats = (0) x ($row_count * 2);
$coins[0] = 0; # initialize with first coin

while (1) {
    my $active = 0;
    # if a coin falls through the bottom, count it
    $stats[$coins[-1] + $row_count]++ if defined $coins[-1];

    # move every coin down one row
    for my $line (reverse 1..(3+$row_count+3) ) {
        my $coinpos = $coins[$line - 1];

        #$coins[$line] = do if (! defined $coinpos) x
        if (! defined $coinpos) {
            $coins[$line] = undef
        } elsif (hits_peg($coinpos, $line)) {
            # when a coin from above hits a peg, it will bounce to either side.
            $active = 1;
            $coinpos += rand() < .5 ? -1 : 1;
            $coins[$line] = $coinpos
        } else {
            # if there was a coin above, it will fall to this position.
            $active = 1;
            $coins[$line] = $coinpos;
        }
    }
    # let the coin dispenser blink and turn it off if we run out of coins
    if (defined $coins[0]) {
        $coins[0] = undef;
    } elsif (--$coins > 0) {
        $coins[0] = 0
    }

    for (<0 1>) {
        display_board(\@coins, \@stats, $_);
        sleep .1;
    }
    exit unless $active;
}

sub display_board {
    my($p_ref, $s_ref, $halfstep) = @_;
    my @positions = @$p_ref;
    my @stats     = @$s_ref;
    my $coin      = $coin_icons[$halfstep];

    my @board = do {
        my @tmpl;

        sub out {
            my(@stuff) = split '', shift;
            my @line;
            push @line, ord($_) for @stuff;
            [@line];
        }

        push @tmpl, out("  " . " "x(2 * $row_count)) for 1..3;
        my @a = reverse 1..$row_count;
        my @b = 1..$row_count;
        my @pairs = pairwise { ($a, $b) } @a, @b;
        for ( pairs @pairs ) {
            my ( $spaces, $pegs ) = @$_;
            push @tmpl, out("  " . " "x$spaces . join(' ',($peg) x $pegs) . " "x$spaces);
        }
        push @tmpl, out("  " . " "x(2 * $row_count)) for 1..4;
        @tmpl;
    };

    my $midpos = $row_count + 2;

    our @output;
    {
        # collect all the output and output it all at once at the end
        sub printnl { my($foo) = @_; push @output, $foo . "\n" }
        sub printl  { my($foo) = @_; push @output, $foo        }

        # make some space above the picture
        printnl("") for 0..9;

        # place the coins
        for my $line (0..$#positions) {
            my $pos = $positions[$line];
            next unless defined $pos;
            $board[$line][$pos + $midpos] = ord($coin);
        }
        # output the board with its coins
        for my $line (@board) {
            printnl join '', map { chr($_) } @$line;
        }

        # show the statistics
        my $padding = 0;
        while (any {$_> 0} @stats) {
            $padding++;
            printl "  ";
            for my $i (0..$#stats) {
                if ($stats[$i] == 1) {
                        printl "\N{UPPER HALF BLOCK}";
                        $stats[$i]--;
                } elsif ($stats[$i] <= 0) {
                        printl " ";
                        $stats[$i] = 0
                } else {
                        printl "\N{FULL BLOCK}";
                        $stats[$i]--; $stats[$i]--;
                }
            }
            printnl("");
        }
        printnl("") for $padding..(10-1);
    }

    print join('', @output) . "\n";
}

sub hits_peg {
    my($x, $y) = @_;
    3 <= $y && $y < (3 + $row_count) and -($y - 2) <= $x && $x <= $y - 2
        ? not 0 == ($x - $y) % 2
        : 0
}


without js -- clear_screen(), text_color(), position(), sleep(), get_key()...
constant balls = 80
clear_screen()
sequence screen = repeat(repeat(' ',23),12)
                & repeat(join(repeat(':',12)),12)
                & {repeat('.',23)},
         Pxy = repeat({12,1},balls)
for peg=1 to 10 do
    screen[peg+2][13-peg..11+peg] = join(repeat('.',peg))
end for
puts(1,join(screen,"\n"))
text_color(BRIGHT_RED)
bool moved = true
integer top = ' '   -- (new drop every other iteration)
while moved or top!=' ' do
    moved = false
    for i=1 to balls do
        integer {Px,Py} = Pxy[i]
        if Py!=1 or top=' ' then
            integer Dx = 0, Dy = 0
            if screen[Py+1,Px]=' ' then     -- can vertical?
                Dy = 1
            else
                Dx = {-1,+1}[rand(2)]       -- try l;r or r;l
                if screen[Py+1,Px+Dx]!=' ' then Dx = -Dx end if
                if screen[Py+1,Px+Dx]==' ' then
                    Dy = 1
                end if
            end if
            if Dy then
                position(Py,Px)  puts(1," ")  screen[Py,Px] = ' '
                Px += Dx
                Py += Dy
                position(Py,Px)  puts(1,"o")  screen[Py,Px] = 'o'
                Pxy[i] = {Px,Py}
                moved = true
                if Py=2 then top = 'o' end if
            end if
        end if
    end for
    position(26,1)
    sleep(0.2)
    if get_key()!=-1 then exit end if
    top = screen[2][12]
end while


(de galtonBox (Pins Height)
   (let (Bins (need (inc (* 2 Pins)) 0)  X 0  Y 0)
      (until (= Height (apply max Bins))
         (call 'clear)
         (cond
            ((=0 Y) (setq X (inc Pins)  Y 1))
            ((> (inc 'Y) Pins)
               (inc (nth Bins X))
               (zero Y) ) )
         ((if (rand T) inc dec) 'X)
         (for Row Pins
            (for Col (+ Pins Row 1)
               (let D (dec (- Col (- Pins Row)))
                  (prin
                     (cond
                        ((and (= X Col) (= Y Row)) "o")
                        ((and (gt0 D) (bit? 1 D)) ".")
                        (T " ") ) ) ) )
            (prinl) )
         (prinl)
         (for H (range Height 1)
            (for B Bins
               (prin (if (>= B H) "o" " ")) )
            (prinl) )
         (wait 200) ) ) )


:- dynamic tubes/1.
:- dynamic balls/2.
:- dynamic stop/1.

% number of rows of pins (0 -> 9)
row(9).

galton_box :-
	retractall(tubes(_)),
	retractall(balls(_,_)),
	retractall(stop(_)),
	assert(stop(@off)),
	new(D, window('Galton Box')),
	send(D, size, size(520,700)),
	display_pins(D),
	new(ChTubes, chain),
	assert(tubes(ChTubes)),
	display_tubes(D, ChTubes),
	new(Balls, chain),
	new(B, ball(D)),
	send(Balls, append, B),
	assert(balls(Balls, D)),
	send(D, done_message, and(message(ChTubes, clear),
				  message(ChTubes, free),
				  message(Balls, for_all, message(@arg1, free)),
				  message(Balls, clear),
				  message(Balls, free),
				  message(@receiver, destroy))),
	send(D, open).

% class pin, balls travel between pins
:- pce_begin_class(pin, circle, "pin").

initialise(P, Pos) :->
	send(P, send_super, initialise, 18),
	send(P, fill_pattern, new(_, colour(@default, 0, 0, 0))),
	get(Pos, x, X),
	get(Pos, y, Y),
	send(P, geometry, x := X, y := Y).
:- pce_end_class.

% class tube, balls fall in them
:- pce_begin_class(tube, path, "tube where balls fall").

variable(indice, any, both, "index of the tube in the list").
variable(balls, any, both, "number of balls inside").

initialise(P, Ind, D) :->
	row(Row),
	send(P, send_super, initialise, kind := poly),
	send(P, slot, balls, 0),
	send(P, slot, indice, Ind),
	X0 is 228 - Row * 20 + Ind * 40,
	X1 is X0 + 20,
	Y1 is 600, Y0 is 350,
	send_list(P, append, [point(X0, Y0), point(X0, Y1),
			      point(X1,Y1), point(X1,Y0)]),
	send(D, display, P).

% animation stop when a tube is full
add_ball(P) :->
	get(P, slot, balls, B),
	B1 is B+1,
	send(P, slot, balls, B1),
	(   B1 = 12
	->  retract(stop(_)), assert(stop(@on))
	;   true).
:- pce_end_class.

% class ball
:- pce_begin_class(ball, circle, "ball").

variable(angle, any, both, "angle of the ball with the pin").
variable(dir, any, both, "left / right").
variable(pin, point, both, "pin under the ball when it falls").
variable(position, point, both, "position of the ball").
variable(max_descent, any, both, "max descent").
variable(state, any, both, "in_pins / in_tube").
variable(window, any, both, "window to display").
variable(mytimer, timer, both, "timer of the animation").

initialise(P, W) :->
	send(P, send_super, initialise, 18),
	send(P, pen, 0),
	send(P, state, in_pins),
	send(P, fill_pattern, new(_, colour(@default, 65535, 0, 0))),
	Ang is 3 * pi / 2,
	send(P, slot, angle, Ang),
	send(P, slot, window, W),
	send(P, geometry, x := 250, y := 30),
	send(P, pin, point(250, 50)),
	send(P, choose_dir),
	send(P, mytimer, new(_, timer(0.005, message(P, move_ball)))),
	send(W, display, P),
	send(P?mytimer, start).

% method called when the object is destroyed
% first the timer is stopped
% then all the resources are freed
unlink(P) :->
	send(P?mytimer, stop),
	send(P, send_super, unlink).

choose_dir(P) :->
	I is random(2),
	(   I = 1 -> Dir = left; Dir = right),
	send(P, dir, Dir).

move_ball(P) :->
	get(P, state, State),
	(   State = in_pins
	->  send(P, move_ball_in_pins)
	;   send(P, move_ball_in_tube)).

move_ball_in_pins(P) :->
	get(P, slot, angle, Ang),
	get(P, slot, pin, Pin),
	get(P, slot, dir, Dir),
	(   Dir = left -> Ang1 is Ang-0.15 ; Ang1 is Ang + 0.15),
	get(Pin, x, PX),
	get(Pin, y, PY),
	X is 21 * cos(Ang1) +  PX,
	Y is 21 * sin(Ang1) + PY,
	send(P, geometry, x := X, y := Y),
	send(P?window, display, P),
	(   abs(Ang1 - pi) < 0.1
	->  PX1 is PX - 20,
	    send(P, next_move, PX1, PY)
	;   abs(Ang1 - 2 * pi) < 0.1
	->  PX1 is PX + 20,
	    send(P, next_move, PX1, PY)
	;   send(P, slot, angle, Ang1)).

next_move(P, PX, PY) :->
	row(Row),

	    Ang2 is 3 * pi / 2,
	    PY1 is PY + 30,
	    (	PY1 =:= (Row + 1) * 30 + 50
	    ->	send(P, slot, state, in_tube),
		NumTube is round((PX - 228 + Row * 20) / 40),
		tubes(ChTubes),
		get(ChTubes, find,
		    message(@prolog, same_value,@arg1?indice, NumTube),
		    Tube),
		send(Tube, add_ball),
		get(Tube, slot, balls, Balls),
		Max_descent is 600 - Balls * 20,
		send(P, slot, max_descent, Max_descent),
		send(P, slot, position, point(PX, PY))
	    ;	send(P, choose_dir),
		send(P, slot, angle, Ang2),
		send(P, slot, pin, point(PX, PY1))).

move_ball_in_tube(P) :->
	get(P, slot, position, Descente),
	get(Descente, x, PX1),
	get(Descente, y, PY),
	PY1 is PY+4,
	send(P, geometry, x := PX1, y := PY1),
	get(P, slot, max_descent, Max_descent),
	(   Max_descent =< PY1
	->  send(P?mytimer, stop),
	    (	stop(@off) ->  send(@prolog, next_ball); true)
	;   send(P, slot, position, point(PX1, PY1))),
	send(P?window, display, P).

:- pce_end_class.

next_ball :-
	retract(balls(Balls, D)),
	new(B, ball(D)),
	send(Balls, append, B),
	assert(balls(Balls, D)).

% test to find the appropriate tube
same_value(V, V).

display_pins(D) :-
	row(Row),
	forall(between(0, Row, I),
	       (  Start is 250 - I * 20,
		  Y is I * 30 + 50,
	          forall(between(0, I, J),
			 (   X is Start + J * 40,
			     new(P, pin(point(X,Y))),
			     send(D, display, P))))).

display_tubes(D, Ch) :-
	row(Row),
	Row1 is Row+1,
	forall(between(0, Row1, I),
	       (   new(T, tube(I, D)),
		   send(Ch, append, T),
		   send(D, display, T))).


Global pegRadius, pegSize, pegSize2, height, width, delay, histogramSize, ball

Procedure eventLoop()
  Protected event
  Repeat
    event = WindowEvent()
    If event = #PB_Event_CloseWindow
      End
    EndIf
  Until event = 0
EndProcedure

Procedure animate_actual(x1, y1, x2, y2, steps)
  Protected x.f, y.f, xstep.f, ystep.f, i, lastX.f, lastY.f
  x = x1
  y = y1
  xstep = (x2 - x1)/steps
  ystep = (y2 - y1)/steps
  For i = 1 To steps
    lastX = x
    lastY = y
    StartDrawing(CanvasOutput(0))
      DrawingMode(#PB_2DDrawing_XOr)
      Circle(x, y, pegRadius, RGB(0, 255, 255))
    StopDrawing()
    eventLoop()
    Delay(delay)      ; wait in ms
    StartDrawing(CanvasOutput(0))
      DrawingMode(#PB_2DDrawing_XOr)
      Circle(x, y, pegRadius, RGB(0, 255, 255))
    StopDrawing()
    eventLoop()
    x + xstep
    y + ystep
  Next
EndProcedure

Procedure draw_ball(xpos, ypos)
  Static Dim ballcounts(0) ;tally drop positions
  If xpos > ArraySize(ballcounts())
    Redim ballcounts(xpos)
  EndIf
  ballcounts(xpos) + 1
  animate_actual(xpos, ypos, xpos, height - ballcounts(xpos) * pegSize, 20)
  StartDrawing(CanvasOutput(0))
    Circle(xpos, height - ballcounts(xpos) * pegSize, pegRadius, RGB(255, 0, 0))
  StopDrawing()
  eventLoop()
  If ballcounts(xpos) <= histogramSize
    ProcedureReturn 1
  EndIf
  SetWindowTitle(0, "Ended after " + Str(ball) + " balls") ;histogramSize exceeded
EndProcedure

Procedure animate(x1, y1, x2, y2)
  animate_actual(x1, y1, x2, y1, 4)
  animate_actual(x2, y1, x2, y2, 10)
EndProcedure

Procedure galton(pegRows)
  ;drop a ball into the galton box
  Protected xpos, ypos, i, oldX, oldY

  oldX = width / 2 - pegSize / 2
  xpos = oldX
  oldY = pegSize
  ypos = oldY
  animate_actual(oldX, 0, xpos, ypos, 10)
  For i = 1 To pegRows
    If Random(1)
      xpos + pegSize
    Else
      xpos - pegSize
    EndIf
    ypos + pegSize2
    animate(oldX, oldY, xpos, ypos)
    oldX = xpos
    oldY = ypos
  Next

  ProcedureReturn draw_ball(xpos, ypos)
EndProcedure

Procedure setup_window(numRows, ballCount)
  ;Draw numRows levels of pegs
  Protected xpos, ypos, i, j

  width = (2 * numRows + 2) * pegSize
  histogramSize = (ballCount + 2) / 3
  If histogramSize > 500 / pegSize: histogramSize = 500 / pegSize: EndIf
  height = width + histogramSize * pegSize
  OpenWindow(0, 0, 0, width, height, "Galton box animation", #PB_Window_SystemMenu)
  CanvasGadget(0, 0, 0, width, height)

  StartDrawing(CanvasOutput(0))
    Box(0, 0, width, height, RGB($EB, $EB, $EB))
    For i = 1 To numRows
      ypos = i * pegSize2
      xpos = width / 2 - (i - 1) * pegSize - pegSize / 2
      For j = 1 To i
        Circle(xpos, ypos, pegRadius, RGB(0, 0, 255))
        xpos + pegSize2
      Next
    Next
    For i = 1 To numRows
      Line((numRows - i + 1) * pegSize2 - pegSize / 2, width - pegSize, 1, histogramSize * pegSize, 0)
    Next
  StopDrawing()
EndProcedure

;based on the galton box simulation from Unicon book
Define pegRows = 10, ballCount
pegRadius = 4
pegSize = pegRadius * 2 + 1
pegSize2 = pegSize * 2
delay = 2                      ; ms delay

Repeat
  ballCount = Val(InputRequester("Galton box simulator","How many balls to drop?", "100"))
Until ballCount > 0

setup_window(pegRows, ballCount)
eventLoop()
For ball = 1 To ballCount
  If Not galton(pegRows): Break: EndIf
Next
Repeat: eventLoop(): ForEver


#!/usr/bin/python

import sys, os
import random
import time

def print_there(x, y, text):
     sys.stdout.write("\x1b7\x1b[%d;%df%s\x1b8" % (x, y, text))
     sys.stdout.flush()

class Ball():
    def __init__(self):
        self.x = 0
        self.y = 0

    def update(self):
        self.x += random.randint(0,1)
        self.y += 1

    def fall(self):
        self.y +=1

class Board():
    def __init__(self, width, well_depth, N):
        self.balls = []
        self.fallen = [0] * (width + 1)
        self.width = width
        self.well_depth = well_depth
        self.N = N
        self.shift = 4

    def update(self):
        for ball in self.balls:
            if ball.y < self.width:
                ball.update()
            elif ball.y < self.width + self.well_depth - self.fallen[ball.x]:
                ball.fall()
            elif ball.y == self.width + self.well_depth - self.fallen[ball.x]:
                self.fallen[ball.x] += 1
            else:
                pass

    def balls_on_board(self):
        return len(self.balls) - sum(self.fallen)

    def add_ball(self):
        if(len(self.balls) <= self.N):
            self.balls.append(Ball())

    def print_board(self):
        for y in range(self.width + 1):
            for x in range(y):
                print_there( y + 1 ,self.width - y + 2*x + self.shift + 1, "#")
    def print_ball(self, ball):
        if ball.y <= self.width:
            x = self.width - ball.y + 2*ball.x + self.shift
        else:
            x = 2*ball.x + self.shift
        y = ball.y + 1
        print_there(y, x, "*")

    def print_all(self):
        print(chr(27) + "[2J")
        self.print_board();
        for ball in self.balls:
            self.print_ball(ball)

def main():
    board = Board(width = 15, well_depth = 5, N = 10)
    board.add_ball() #initialization
    while(board.balls_on_board() > 0):
         board.print_all()
         time.sleep(0.25)
         board.update()
         board.print_all()
         time.sleep(0.25)
         board.update()
         board.add_ball()

if __name__=="__main__":
    main()


;a ball's position...row is a natural number and col is an integer where 0 is the center
(define-struct pos (row col))
;state of simulation...list of all positions and vector of balls (index = bin)
(define-struct st (poss bins))
;increment vector @i
(define (vector-inc! v i) (vector-set! v i (add1 (vector-ref v i))))

(define BALL-RADIUS 6)
;for balls to fit perfectly between diamond-shaped pins, the side length is
;determined by inscribing the diamond in the circle
(define PIN-SIDE-LENGTH (* (sqrt 2) BALL-RADIUS))
;ultimate pin width and height
(define PIN-WH (* 2 BALL-RADIUS))
(define PIN-HOR-SPACING (* 2 PIN-WH))
;vertical space is the height of an equilateral triangle with side length = PIN-HOR-SPACING
(define PIN-VER-SPACING (* 1/2 (sqrt 3) PIN-HOR-SPACING))
;somewhat copying BASIC256's graphics
;determines how thick the outline will be
(define FILL-RATIO 0.7)
;freeze is a function that converts the drawing code into an actual bitmap forever
(define PIN (freeze (overlay (rotate 45 (square (* FILL-RATIO PIN-SIDE-LENGTH) "solid" "purple"))
                             (rotate 45 (square PIN-SIDE-LENGTH "solid" "magenta")))))
(define BALL (freeze (overlay (circle (* FILL-RATIO BALL-RADIUS) "solid" "green")
                              (circle BALL-RADIUS "solid" "dark green"))))
(define BIN-COLOR (make-color 255 128 192))
;# balls bin can fit
(define BIN-CAPACITY 10)
(define BIN-HEIGHT (* BIN-CAPACITY PIN-WH))
(define BIN (freeze (beside/align "bottom"
                                  (line 0 BIN-HEIGHT BIN-COLOR)
                                  (line PIN-WH 0 BIN-COLOR)
                                  (line 0 BIN-HEIGHT BIN-COLOR))))

(define draw-background
  (let ([background #f])
    (λ (height)
      (if (image? background)
          background
          (let* ([w (+ (image-width BIN) (* PIN-HOR-SPACING height))]
                 [h (+ PIN-WH (image-height BIN) (* PIN-VER-SPACING height))]
                 [draw-background (λ () (rectangle w h "solid" "black"))])
            (begin (set! background (freeze (draw-background))) background))))))

;draws images using x horizontal space between center points
(define (spaced/x x is)
  (if (null? is)
      (empty-scene 0 0)
      (let spaced/x ([n 1] [i (car is)] [is (cdr is)])
        (if (null? is)
            i
            (overlay/xy i (* -1 n x) 0 (spaced/x (add1 n) (car is) (cdr is)))))))

(define (draw-pin-row r) (spaced/x PIN-HOR-SPACING (make-list (add1 r) PIN)))

;draws all pins, using saved bitmap for efficiency
(define draw-pins
  (let ([bmp #f])
    (λ (height)
      (let ([draw-pins (λ () (foldl (λ (r i) (overlay/align/offset
                                              ;vertically line up all pin rows
                                              "center" "bottom" (draw-pin-row r)
                                              ;shift down from the bottom of accum'ed image by ver spacing
                                              0 (- PIN-VER-SPACING) i))
                                    (draw-pin-row 0) (range 1 height 1)))])
        (if (image? bmp)
            bmp
            (begin (set! bmp (freeze (draw-pins))) bmp))))))

(define (draw-ball p i)
  ;the ball starts at the top of the image
  (overlay/align/offset "center" "top" BALL (* -1 (pos-col p) PIN-WH) (* -1 (pos-row p) PIN-VER-SPACING) i))

;bin has balls added from bottom, stacked exactly on top of each other
;the conditional logic is needed because above can't handle 0 or 1 things
(define (draw-bin n)
  (if (zero? n)
      BIN
      (overlay/align "center" "bottom"
                     (if (= n 1) BALL (apply above (make-list n BALL)))
                     BIN)))

;main drawing function
(define (draw height s)
  (let* ([bins (spaced/x PIN-HOR-SPACING (map draw-bin (vector->list (st-bins s))))]
         ;pins above bins
         [w/pins (above (draw-pins height) bins)]
         ;draw this all one ball diameter (PIN-WH) below top
         [w/background (overlay/align/offset "center" "top" w/pins
                                             0 (- PIN-WH) (draw-background height))])
    ;now accumulate in each ball
    (foldl draw-ball w/background (st-poss s))))

;a ball moves down by increasing its row and randomly changing its col by -1 or 1
(define (next-row height p)
  (make-pos (add1 (pos-row p))
            (+ -1 (* 2 (random 2)) (pos-col p))))

;each step, every ball goes to the next row and new balls are added at the top center
;balls that fall off go into bins
(define (tock height s)
  (let* ([new-ps (map (λ (p) (next-row height p)) (st-poss s))]
         ;live balls haven't gone past the last row of pins
         [live (filter (λ (p) (< (pos-row p) height)) new-ps)]
         ;dead balls have (partition from normal Racket would be useful here...)
         [dead (filter (λ (p) (>= (pos-row p) height)) new-ps)]
         ;adjust col from [-x,x] to [0,2x]
         [bin-indices (map (λ (p) (quotient (+ (pos-col p) height) 2)) dead)])
    ;add new balls to the live balls
    (make-st (append (make-list (random 4) (make-pos 0 0)) live)
             ;sum dead ball positions into bins
             (begin (for-each (λ (i) (vector-inc! (st-bins s) i)) bin-indices)
                    (st-bins s)))))

;run simulation with empty list of positions to start, stepping with "tock" and drawing with "draw"
(define (run height)
  (big-bang (make-st '() (make-vector (add1 height) 0))
            (on-tick (λ (ps) (tock height ps)) 0.5)
            (to-draw (λ (ps) (draw height ps)))))


my $row-count = 6;

constant $peg = "*";
constant @coin-icons = "\c[UPPER HALF BLOCK]", "\c[LOWER HALF BLOCK]";

sub display-board(@positions, @stats is copy, $halfstep) {
    my $coin = @coin-icons[$halfstep.Int];

    state @board-tmpl = {
        # precompute a board
        my @tmpl;
        sub out(*@stuff) {
            @tmpl.push: $[@stuff.join>>.ords.flat];
        }
        # three lines of space above
        for 1..3 {
            out "  ", " " x (2 * $row-count);
        }
        # $row-count lines of pegs
        for flat ($row-count...1) Z (1...$row-count) -> $spaces, $pegs {
            out "  ", " " x $spaces, ($peg xx $pegs).join(" "), " " x $spaces;
        }
        # four lines of space below
        for 1..4 {
            out "  ", " " x (2 * $row-count);
        }
        @tmpl
    }();

    my $midpos = $row-count + 2;

    my @output;
    {
        # collect all the output and output it all at once at the end
        sub say(Str $foo) {
            @output.push: $foo, "\n";
        }
        sub print(Str $foo) {
            @output.push: $foo;
        }

        # make some space above the picture
        say "" for ^10;

        my @output-lines = map { [ @$_ ] }, @board-tmpl;
        # place the coins
        for @positions.kv -> $line, $pos {
            next unless $pos.defined;
            @output-lines[$line][$pos + $midpos] = $coin.ord;
        }
        # output the board with its coins
        for @output-lines -> @line {
            say @line.chrs;
        }

        # show the statistics
        my $padding = 0;
        while any(@stats) > 0 {
            $padding++;
            print "  ";
            @stats = do for @stats -> $stat {
                given $stat {
                    when 1 {
                        print "\c[UPPER HALF BLOCK]";
                        $stat - 1;
                    }
                    when * <= 0 {
                        print " ";
                        0
                    }
                    default {
                        print "\c[FULL BLOCK]";
                        $stat - 2;
                    }
                }
            }
            say "";
        }
        say "" for $padding...^10;
    }
    say @output.join("");
}

sub simulate($coins is copy) {
    my $alive = True;

    sub hits-peg($x, $y) {
        if 3 <= $y < 3 + $row-count and -($y - 2) <= $x <= $y - 2 {
            return not ($x - $y) %% 2;
        }
        return False;
    }

    my @coins = Int xx (3 + $row-count + 4);
    my @stats = 0 xx ($row-count * 2);
    # this line will dispense coins until turned off.
    @coins[0] = 0;
    while $alive {
        $alive = False;
        # if a coin falls through the bottom, count it
        given @coins[*-1] {
            when *.defined {
                @stats[$_ + $row-count]++;
            }
        }

        # move every coin down one row
        for ( 3 + $row-count + 3 )...1 -> $line {
            my $coinpos = @coins[$line - 1];

            @coins[$line] = do if not $coinpos.defined {
                Nil
            } elsif hits-peg($coinpos, $line) {
                # when a coin from above hits a peg, it will bounce to either side.
                $alive = True;
                ($coinpos - 1, $coinpos + 1).pick;
            } else {
                # if there was a coin above, it will fall to this position.
                $alive = True;
                $coinpos;
            }
        }
        # let the coin dispenser blink and turn it off if we run out of coins
        if @coins[0].defined {
            @coins[0] = Nil
        } elsif --$coins > 0 {
            @coins[0] = 0
        }

        # smooth out the two halfsteps of the animation
        my $start-time;
        ENTER { $start-time = now }
        my $wait-time = now - $start-time;

        sleep 0.1 - $wait-time if $wait-time < 0.1;
        for @coin-icons.keys {
            sleep $wait-time max 0.1;
            display-board(@coins, @stats, $_);
        }
    }
}

sub MAIN($coins = 20, $peg-lines = 6) {
    $row-count = $peg-lines;
    simulate($coins);
}


/*REXX pgm simulates Sir Francis Galton's box, aka: Galton Board, quincunx, bean machine*/
trace off                                        /*suppress any messages for negative RC*/
if !all(arg())  then exit                        /*Any documentation was wanted?   Done.*/
signal on halt                                   /*allow the user to  halt  the program.*/
parse arg rows balls freeze seed .               /*obtain optional arguments from the CL*/
if rows ==''  |  rows==","   then   rows=   0    /*Not specified?  Then use the default.*/
if balls==''  | balls==","   then  balls= 100    /* "      "         "   "   "     "    */
if freeze=='' | freeze==","  then freeze=   0    /* "      "         "   "   "     "    */
if datatype(seed, 'W')   then call random ,,seed /*Was a seed specified?  Then use seed.*/
pin  = '·';              ball = '☼'              /*define chars for a  pin  and a  ball.*/
parse value  scrsize()   with   sd  sw  .        /*obtain the terminal depth and width. */
if sd==0  then sd= 40                            /*Not defined by the OS?  Use a default*/
if sw==0  then sw= 80                            /* "     "     "  "   "    "  "    "   */
sd= sd - 3                                       /*define the usable       screen depth.*/
sw= sw - 1;  if sw//2  then sw= sw - 1           /*   "    "    "     odd     "   width.*/
if rows==0  then rows= (sw - 2 ) % 3             /*pins are on the first third of screen*/
call gen                                         /*gen a triangle of pins with some rows*/
           do step=1;  call drop;  call show     /*show animation 'til run out of balls.*/
           end   /*step*/                        /* [↑]  the dropping/showing   "   "   */
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
gen: @.=;  do r=0  by 2  to rows;     $=         /*build a triangle of pins for the box.*/
                do pins=1  for r%2;   $= $  pin  /*build a row of pins to be displayed. */
                end   /*pins*/
           @.r= center( strip($, 'T'), sw)       /*an easy method to build a triangle.  */
           end     /*r*/;     #= 0;       return /*#:   is the number of balls dropped. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
drop: static= 1                                  /*used to indicate all balls are static*/
        do c=sd-1  by -1  for sd-1;    n= c + 1  /*D:  current row;   N:  the next row. */
        x= pos(ball, @.c);             y= x - 1  /*X:  position of a ball on the C line.*/
        if x==0  then iterate                    /*No balls here?  Then nothing to drop.*/
          do forever;   y= pos(ball, @.c, y+1)   /*drop most balls down to the next row.*/
          if y==0  then iterate c                /*down with this row, go look at next. */
          z= substr(@.n, y, 1)                   /*another ball is blocking this fall.  */
          if z==' '  then do;  @.n= overlay(ball, @.n, y)   /*drop a ball straight down.*/
                               @.c= overlay(' ' , @.c, y)   /*make current ball a ghost.*/
                               static= 0                    /*indicate balls are moving.*/
                               iterate                      /*go keep looking for balls.*/
                          end
          if z==pin  then do;  ?= random(,999);   d= -1     /*assume falling to the left*/
                                    if ?//2  then d=  1     /*if odd random#, fall right*/
                               if substr(@.n, y+d, 1)\==' '  then iterate /*blocked fall*/
                               @.n= overlay(ball, @.n, y+d)
                               @.c= overlay(' ' , @.c, y  )
                               static= 0                    /*indicate balls are moving.*/
                               iterate                      /*go keep looking for balls.*/
                          end
          end   /*forever*/
        end     /*c*/                  /* [↓]   step//2    is used to avoid collisions. */
                                                            /* [↓]  drop a new ball ?   */
     if #<balls & step//2  then do;    @.1= center(ball, sw+1);      # = # + 1;        end
                           else if static  then exit 2      /*insure balls are static.  */
     return
/*──────────────────────────────────────────────────────────────────────────────────────*/
show: !cls;    do LR=sd  by -1  until @.LR\==''                 /*LR:  last row of data.*/
               end   /*LR*/;                 ss= 'step' step    /* [↓]   display a row. */
        do r=1  for LR; _= strip(@.r, 'T');  if r==2  then _= overlay(ss, _, sw-12); say _
        end   /*r*/;   if step==freeze  then do;   say 'press ENTER ···';    pull;   end
      return
/*══════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════════*/
halt:  say '***warning***  REXX program'   !fn    "execution halted by user.";      exit 1
!all:  !!=!;!=space(!);upper !;call !fid;!nt=right(!var('OS'),2)=='NT';!cls=word('CLS VMFCLEAR CLRSCREEN',1+!cms+!tso*2);if arg(1)\==1 then return 0;if wordpos(!,'? ?SAMPLES ?AUTHOR ?FLOW')==0 then return 0;!call=']$H';call '$H' !fn !;!call=;return 1
!cal:  if symbol('!CALL')\=="VAR"  then !call=;                                  return !call
!env:  !env='ENVIRONMENT';    if !sys=='MSDOS' | !brexx | !r4 | !roo  then !env= 'SYSTEM';    if !os2  then !env= 'OS2'!env;    !ebcdic=  2=='f2'x;    if !crx  then !env= 'DOS';                     return
!fid:  parse upper source !sys !fun !fid . 1 . . !fn !ft !fm .;  call !sys;   if !dos  then do;  _= lastpos('\', !fn);  !fm= left(!fn, _);  !fn= substr(!fn, _+1);  parse var !fn !fn '.' !ft;  end;  return word(0 !fn !ft !fm, 1 + ('0'arg(1) ) )
!rex:  parse upper version !ver !vernum !verdate .; !brexx= 'BY'==!vernum; !kexx= 'KEXX'==!ver; !pcrexx= 'REXX/PERSONAL'==!ver | 'REXX/PC'==!ver; !r4= 'REXX-R4'==!ver; !regina= 'REXX-REGINA'==left(!ver, 11); !roo= 'REXX-ROO'==!ver; call !env;  return
!sys:  !cms= !sys=='CMS';  !os2= !sys=='OS2';  !tso= !sys=='TSO' | !sys=='MVS';  !vse= !sys=='VSE';  !dos= pos('DOS', !sys)\==0 | pos('WIN', !sys)\==0 | !sys=='CMD';  !crx= left(!sys, 6)=='DOSCRX';  call !rex;  return
!var:  call !fid;  if !kexx  then return space( dosenv( arg(1) ) );              return space( value( arg(1), , !env) )


$rows_of_pins = 12
$width = $rows_of_pins * 10 + ($rows_of_pins+1)*14

Shoes.app(
    :width => $width + 14,
    :title => "Galton Box"
) do
  @bins = Array.new($rows_of_pins+1, 0)

  @x_coords = Array.new($rows_of_pins) {Array.new}
  @y_coords = Array.new($rows_of_pins)
  stack(:width => $width) do
    stroke gray
    fill gray
    1.upto($rows_of_pins) do |row|
      y = 14 + 24*row
      @y_coords[row-1] = y
      row.times do |i|
        x = $width / 2 + (i - 0.5*row)*24 + 14
        @x_coords[row-1] << x
        oval x+2, y, 6
      end
    end
  end
  @y_coords << @y_coords[-1] + 24
  @x_coords << @x_coords[-1].map {|x| x-12} + [@x_coords[-1][-1]+12]

  @balls = stack(:width => $width) do
    stroke red
    fill red
  end.move(0,0)

  @histogram = stack(:width => $width) do
    nostroke
    fill black
  end.move(0, @y_coords[-1] + 10)

  @paused = false
  keypress do |key|
    case key
    when "\x11", :control_q
      exit
    when "\x10", :control_p
      @paused = [email protected]
    end
  end

  @ball_row = 0
  @ball_col = 0
  animate(2*$rows_of_pins) do
    if not @paused
      y = @y_coords[@ball_row] - 12
      x = @x_coords[@ball_row][@ball_col]
      @balls.clear {oval x, y, 10}
      @ball_row += 1
      if @ball_row <= $rows_of_pins
        @ball_col += 1 if rand >= 0.5
      else
        @bins[@ball_col] += 1
        @ball_row = @ball_col = 0
        update_histogram
      end
    end
  end

  def update_histogram
    y = @y_coords[-1] + 10
    @histogram.clear do
      @bins.each_with_index do |num, i|
        if num > 0
          x = @x_coords[-1][i]
          rect x-6, 0, 24, num
        end
      end
    end
  end
end


package require Tcl 8.6

oo::class create GaltonBox {
    variable b w h n x y cnt step dropping

    constructor {BALLS {NUMPEGS 5} {HEIGHT 24}} {
	set n $NUMPEGS
	set w [expr {$n*2 + 1}]
	set h $HEIGHT
	puts -nonewline "\033\[H\033\[J"
	set x [set y [lrepeat $BALLS 0]]
	set cnt 0
	set step 0
	set dropping 1

	set b [lrepeat $h [lrepeat $w " "]]
	for {set i 0} {$i < $n} {incr i} {
	    for {set j [expr {-$i}]} {$j <= $i} {incr j 2} {
		lset b [expr {2*$i+2}] [expr {$j+$w/2}] "*"
	    }
	}
    }

    method show {} {
	puts -nonewline "\033\[H"
	set oldrow {}
	foreach row $b {
	    foreach char $row oldchar $oldrow {
		if {$char ne "*"} {
		    puts -nonewline "$char "
		} elseif {$oldchar eq " "} {
		    puts -nonewline "\033\[32m*\033\[m "
		} else {
		    puts -nonewline "\033\[31m*\033\[m "
		}
	    }
	    set oldrow $row
	    puts ""
	}
    }

    method Move idx {
	set xx [lindex $x $idx]
	set yy [lindex $y $idx]
	set kill 0

	if {$yy < 0} {return 0}
	if {$yy == $h-1} {
	    lset y $idx -1
	    return 0
	}

	switch [lindex $b [incr yy] $xx] {
	    "*" {
		incr xx [expr {2*int(2 * rand()) - 1}]
		if {[lindex $b [incr yy -1] $xx] ne " "} {
		    set dropping 0
		}
	    }
	    "o" {
		incr yy -1
		set kill 1
	    }
	}

	set c [lindex $b [lindex $y $idx] [lindex $x $idx]]
	lset b [lindex $y $idx] [lindex $x $idx] " "
	lset b $yy $xx $c
	if {$kill} {
	    lset y $idx -1
	} else {
	    lset y $idx $yy
	}
	lset x $idx $xx
	return [expr {!$kill}]
    }

    method step {} {
	set moving 0
	for {set i 0} {$i < $cnt} {incr i} {
	    set moving [expr {[my Move $i] || $moving}]
	}
	if {2 == [incr step] && $cnt < [llength $x] && $dropping} {
	    set step 0
	    lset x $cnt [expr {$w / 2}]
	    lset y $cnt 0
	    if {[lindex $b [lindex $y $cnt] [lindex $x $cnt]] ne " "} {
		return 0
	    }
	    lset b [lindex $y $cnt] [lindex $x $cnt] "o"
	    incr cnt
	}
	return [expr {($moving || $dropping)}]
    }
}

GaltonBox create board 1024 {*}$argv
while true {
    board show
    if {[board step]} {after 60} break
}


import "random" for Random
import "/trait" for Reversed

var boxW = 41       // Galton box width.
var boxH = 37       // Galton box height.
var pinsBaseW = 19  // Pins triangle base.
var nMaxBalls = 55  // Number of balls.

var centerH = pinsBaseW + (boxW - pinsBaseW * 2 + 1) / 2 - 1
var Rand = Random.new()

class Cell {
    static EMPTY  { " " }
    static BALL   { "o" }
    static WALL   { "|" }
    static CORNER { "+" }
    static FLOOR  { "-" }
    static PIN    { "." }
}

/* Galton box. Will be printed upside down. */
var Box = List.filled(boxH, null)
for (i in 0...boxH) Box[i] = List.filled(boxW, Cell.EMPTY)

class Ball {
    construct new(x, y) {
        if (Box[x][y] != Cell.EMPTY) Fiber.abort("The cell at (x, y) is not empty.")
        Box[y][x] = Cell.BALL
        _x = x
        _y = y
    }

    doStep() {
        if (_y <= 0) return  // Reached the bottom of the box.
        var cell = Box[_y - 1][_x]
        if (cell == Cell.EMPTY) {
            Box[_y][_x] = Cell.EMPTY
            _y = _y - 1
            Box[_y][_x] = Cell.BALL
        } else if (cell == Cell.PIN) {
            Box[_y][_x] = Cell.EMPTY
            _y = _y - 1
            if (Box[_y][_x - 1] == Cell.EMPTY && Box[_y][_x + 1] == Cell.EMPTY) {
                _x = _x + Rand.int(2) * 2 - 1
                Box[_y][_x] = Cell.BALL
                return
            } else if (Box[_y][_x - 1] == Cell.EMPTY){
                _x = _x + 1
            } else _x = _x - 1
            Box[_y][_x] = Cell.BALL
        } else {
            // It's frozen - it always piles on other balls.
        }
    }
}

var initializeBox = Fn.new {
    // Set ceiling and floor:
    Box[0][0] = Cell.CORNER
    Box[0][boxW - 1] = Cell.CORNER
    for (i in 1...boxW - 1) Box[0][i] = Cell.FLOOR
    for (i in 0...boxW) Box[boxH - 1][i] = Box[0][i]

    // Set walls:
    for (r in 1...boxH - 1) {
        Box[r][0] = Cell.WALL
        Box[r][boxW - 1] = Cell.WALL
    }

    // Set pins:
    for (nPins in 1..pinsBaseW) {
        for (pin in 0...nPins) {
            Box[boxH - 2 - nPins][centerH + 1 - nPins + pin * 2] = Cell.PIN
        }
    }
}

var drawBox = Fn.new() {
    for (row in Reversed.new(Box, 1)) {
        for (c in row) System.write(c)
        System.print()
    }
}

initializeBox.call()
var balls = []
for (i in 0...nMaxBalls + boxH) {
    System.print("\nStep %(i):")
    if (i < nMaxBalls) balls.add(Ball.new(centerH, boxH - 2))  // Add ball.
    drawBox.call()

    // Next step for the simulation.
    // Frozen balls are kept in balls list for simplicity
    for (b in balls) b.doStep()
}


include c:\cxpl\codes;          \intrinsic code declarations
define  Balls = 80;             \maximum number of balls
int     Bx(Balls), By(Balls),   \character cell coordinates of each ball
        W, I, J, Peg, Dir;
[W:= Peek($40, $4A);            \get screen width in characters
Clear;  CrLf(6);  CrLf(6);
for Peg:= 1 to 10 do                            \draw pegs
        [for I:= 1 to 12-Peg do ChOut(6,^ );    \space over to first peg
         for I:= 1 to Peg do [ChOut(6,^.);  ChOut(6,^ )];
        CrLf(6);
        ];
for J:= 0 to 12-1 do                            \draw slots
        [for I:= 0 to 12-1 do [ChOut(6,^:);  ChOut(6,^ )];
        CrLf(6);
        ];
for I:= 0 to 23-1 do ChOut(6,^.);               \draw bottom
for I:= 0 to Balls-1 do                         \make source of balls at top
        [Bx(I):= 11;  By(I):= 1];
Attrib($C);                                     \make balls bright red
repeat                                          \balls away! ...
    for I:= 0 to Balls-1 do                     \for all the balls ...
        [Cursor(Bx(I), By(I));  ChOut(6, ^ );   \erase ball's initial position
        if Peek($B800, (Bx(I)+(By(I)+1)*W)*2) = ^ \is ball above empty location?
        then    By(I):= By(I)+1                 \yes: fall straight down
        else    [Dir:= Ran(3)-1;                \no: randomly fall right or left
                if Peek($B800, (Bx(I)+Dir+(By(I)+1)*W)*2) = ^  then
                        [Bx(I):= Bx(I)+Dir;  By(I):= By(I)+1];
                ];
        Cursor(Bx(I), By(I));  ChOut(6, ^o);    \draw ball at its new position
        ];
    Sound(0, 3, 1);                             \delay about 1/6 second
until KeyHit;                                   \continue until a key is struck
]


bola$ = "0000ff"
obst$ = "000000"

maxBalls = 10
cx = 1
cy = 2
dim Balls(maxBalls, 2)

open window 600,600
window origin "ct"

maxh = peek("winheight")

REM Draw the pins:

FOR row = 1 TO 7
  FOR col = 1 TO row
    FILL circle 40*col - 20*row, 40*row+80, 10
  NEXT col
NEXT row

REM Animate
tick = 0
bolas = 0
color 0,0,255

do
	if (bolas < maxBalls) then
		if tick = 3 then
			tick = 0
			bolas = bolas + 1
			Balls(bolas, cx) = 20
			Balls(bolas, cy) = 10
		end if
		tick = tick + 1
	end if
	for n = 1 to bolas
		if Balls(n, cy) then
			color$ = right$(getbit$(Balls(n,cx),Balls(n,cy) + 10,Balls(n,cx),Balls(n,cy) + 10),6)
			if (color$ = bola$) or (Balls(n,cy) >= maxh - 15) then
				Balls(n,cy) = 0
				break
			end if
			clear fill circle Balls(n,cx),Balls(n,cy),10
			if color$ = obst$ then
				if int(ran(2)) then
					Balls(n,cx) = Balls(n,cx) - 20
				else
					Balls(n,cx) = Balls(n,cx) + 20
				end if
			end if
			Balls(n,cy) = Balls(n,cy)+10
			fill circle Balls(n,cx),Balls(n,cy),10
			wait .001
		else
			wait .001
		end if
	next n
loop


const std = @import("std");
const rand = std.rand;
const time = std.os.time;

const PEG_LINES = 20;

fn boardSize(comptime peg_lines: u16) u16 {
    var i: u16 = 0;
    var size: u16 = 0;
    inline while (i <= PEG_LINES) : (i += 1) {
        size += i+1;
    }
    return size;
}

const BOARD_SIZE = boardSize(PEG_LINES);

fn stepBoard(board: *[BOARD_SIZE]u1, count: *[PEG_LINES+1]u8) void {
    var prng = rand.DefaultPrng.init(time.timestamp());

    var p: u8 = 0;
    var sum: u16 = 0;
    while (p <= PEG_LINES) : (p += 1) {
        const pegs = PEG_LINES-p;
        var i: u16 = 0;
        while (i < pegs+1) : (i += 1) {
            if (pegs != PEG_LINES and board[BOARD_SIZE-1-sum-i] == 1) {
                if (prng.random.boolean()) {
                    board.*[BOARD_SIZE-1-sum-i+pegs+1] = 1;
                } else {
                    board.*[BOARD_SIZE-1-sum-i+pegs+2] = 1;
                }
            } else if (pegs == PEG_LINES and board[BOARD_SIZE-1-sum-i] == 1) {
                count.*[pegs-i] += 1;
            }
            board.*[BOARD_SIZE-1-sum-i] = 0;
        }
        sum += pegs+1;
    }
}

fn printBoard(board: *[BOARD_SIZE]u1, count: *[PEG_LINES+1]u8) !void {
    var stdout = try std.io.getStdOut();
    try stdout.write("\x1B[2J\x1B[1;1H");
    var pegs: u16 = 0;
    var sum: u16 = 0;
    while (pegs <= PEG_LINES) : (pegs += 1) {
        var i: u16 = 0;
        while (i < (PEG_LINES-pegs)) : (i += 1) try stdout.write(" ");
        i = 0;
        while (i < pegs+1) : (i += 1) {
            const spot = if (board[i+sum] == 1) "o" else " ";
            try stdout.write(spot);
            if (i != pegs) try stdout.write("*");
        }
        sum += pegs+1;
        try stdout.write("\n");
    }
    for (count) |n| {
        const num_char = [2]u8{'0'+n, ' '};
        try stdout.write(num_char);
    }
    try stdout.write("\n");
}

pub fn main() !void {
    var board: [BOARD_SIZE]u1 = []u1{0} ** BOARD_SIZE;
    var bottom_count: [PEG_LINES+1]u8 = []u8{0} ** (PEG_LINES+1);

    var i: u16 = 0;
    while (i < 35) : (i += 1) {
        if (i < 10) board[0] = 1;

        try printBoard(&board, &bottom_count);
        stepBoard(&board, &bottom_count);
        time.sleep(150000000);
    }
}


V compose = (f, g) -> (x -> @f(@g(x)))
V sin_asin = compose(x -> sin(x), x -> asin(x))
print(sin_asin(0.5))


function compose(f:Function, g:Function):Function {
	return function(x:Object) {return f(g(x));};
}
function test() {
	trace(compose(Math.atan, Math.tan)(0.5));
}


generic
   type Argument is private;
package Functions is
   type Primitive_Operation is not null
      access function (Value : Argument) return Argument;
   type Func (<>) is private;
   function "*" (Left : Func; Right : Argument) return Argument;
   function "*" (Left : Func; Right : Primitive_Operation) return Func;
   function "*" (Left, Right : Primitive_Operation) return Func;
   function "*" (Left, Right : Func) return Func;
private
   type Func is array (Positive range <>) of Primitive_Operation;
end Functions;


compose : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
        → (B → C)
        → (A → B)
        → A → C
compose f g x = f (g x)


import math

function compose (f, g) {
    return function (x) { return f(g(x)) }
}

var func = compose(Math.sin, Math.asin)
println (func(0.5))   //  0.5


compose_i(,,)
{
    ($0)(($1)($2));
}

compose(,)
{
    compose_i.apply($0, $1);
}

double(real a)
{
    2 * a;
}

square(real a)
{
    a * a;
}

main(void)
{
    o_(compose(square, double)(40), "\n");

    0;
}


MODE F = PROC(REAL)REAL; # ALGOL 68 is strong typed #

# As a procedure for real to real functions #
PROC compose = (F f, g)F: (REAL x)REAL: f(g(x));

OP (F,F)F O = compose; # or an OPerator that can be overloaded #

# Example use: #
F sin arc sin = compose(sin, arc sin);
print((sin arc sin(0.5), (sin O arc sin)(0.5), new line))


/Apply g to exactly one argument
compose1: {f: x; g: y; {f[g[x]]}}
/Extra: apply to multiple arguments
compose: {f: x; g: y; {f[g apply args]}}


-- Compose two functions where each function is
-- a script object with a call(x) handler.
on compose(f, g)
    script
        on call(x)
            f's call(g's call(x))
        end call
    end script
end compose

script sqrt
    on call(x)
        x ^ 0.5
    end call
end script

script twice
    on call(x)
        2 * x
    end call
end script

compose(sqrt, twice)'s call(32)
-- Result: 8.0


10 F$ = "SIN"
20 DEF FN A(P) = ATN(P/SQR(-P*P+1))
30 G$ = "FN A"
40 GOSUB 100"COMPOSE
50 SA$ = E$

60 X = .5 : E$ = SA$
70 GOSUB 200"EXEC
80 PRINT R
90 END

100 E$ = F$ + "(" + G$ + "(X))" : RETURN : REMCOMPOSE F$ G$

200 D$ = CHR$(4) : FI$ = "TEMPORARY.EX" : M$ = CHR$(13)
210 PRINT D$"OPEN"FI$M$D$"CLOSE"FI$M$D$"DELETE"FI$
220 PRINT D$"OPEN"FI$M$D$"WRITE"FI$
230 PRINT "CALL-998:CALL-958:R="E$":CONT"
240 PRINT D$"CLOSE"FI$M$D$"EXEC"FI$:CALL-998:END:RETURN


use std, math

let my_asin = new Function (.:<any,real x>:. -> real {asin x})
let my__sin = new Function (.:<any,real x>:. -> real { sin x})
let sinasin = my__sin o my_asin
print sin asin 0.5
print *my__sin 0.0
print *sinasin 0.5
~my_asin
~my__sin
~sinasin

=: <Function f> o <Function g> := -> Function {compose f g}

.:compose <Function f, Function g>:. -> Function
  use array
  let d = (new array of 2 Function)
  (d[0]) = f ; (d[1]) = g
  let c = new Function (.:<array of Function fg, real x>:. -> real {
    *fg[0]( *fg[1](x) )
  }) (d)
  c.del = .:<any>:.{free any}
  c

class Function
  function(any)(real)->(real)	func
  any				data
  function(any)			del

=: * <Function f> <real x> := -> real
   Cgen "(*("(f.func)"))("(f.data)", "(x)")"

.: del Function <Function f> :.
   unless f.del is nil
     call f.del with f.data
   free f
=: ~ <Function f> := {del Function f}

.: new Function <function(any)(real)-\>real func> (<any data>):. -> Function
   let f = new Function
   f.func = func
   f.data = data
   f


compose: function [f,g] ->
    return function [x].import:[f,g][
        call f @[call g @[x]]
    ]

splitupper: compose 'split 'upper

print call 'splitupper ["done"]


(*
   The task:

      Create a function, compose, whose two arguments f and g, are
      both functions with one argument.

      The result of compose is to be a function of one argument,
      (let's call the argument x), which works like applying function
      f to the result of applying function g to x.

   In ATS, we have to choose whether to use non-linear closures
   (cloref) or linear closures (cloptr). In the latter case, we also
   have to choose between closures allocated with malloc (or similar)
   and closures allocated on the stack.

   For simplicity, we will use non-linear closures and assume there is
   a garbage collector, or that the memory allocated for the closures
   can be allowed to leak. (This is often the case in a program that
   does not run continuously.)
*)

#include "share/atspre_staload.hats"

(* The following is actually a *template function*, rather than a
   function proper. It is expanded during template processing. *)

fn {t1, t2, t3 : [email protected]}
compose (f : t2 -<cloref1> t3,
         g : t1 -<cloref1> t2) : t1 -<cloref1> t3 =
  lam x => f (g (x))

implement
main0 () =
  let
    val one_hundred = 100.0
    val char_zero = '0'
    val f = (lam y =<cloref1> add_double_int (one_hundred, y))
    val g = (lam x =<cloref1> char2i x - char2i char_zero)
    val z = compose (f, g) ('5')
    val fg = compose (f, g)
    val w = fg ('7')
  in
    println! (z : double);
    println! (w : double)
  end


MsgBox % compose("sin","cos",1.5)

compose(f,g,x) { ; function composition
   Return %f%(%g%(x))
}


      REM Create some functions for testing:
      DEF FNsqr(a) = SQR(a)
      DEF FNabs(a) = ABS(a)

      REM Create the function composition:
      SqrAbs = FNcompose(FNsqr(), FNabs())

      REM Test calling the composition:
      x = -2 : PRINT ; x, FN(SqrAbs)(x)
      END

      DEF FNcompose(RETURN f%, RETURN g%)
      LOCAL f$, p% : DIM p% 7 : p%!0 = f% : p%!4 = g%
      f$ = "(x)=" + CHR$&A4 + "(&" + STR$~p% + ")(" + \
      \             CHR$&A4 + "(&" + STR$~(p%+4) + ")(x))"
      DIM p% LEN(f$) + 4 : $(p%+4) = f$ : !p% = p%+4
      = p%


double sin (double v)	{ return Math.sin(v); }
double asin (double v)	{ return Math.asin(v); }
Var compose (Func f, Func g, double d)	{ return f(g(d)); }

void button1_onClick (Widget widget)
{
	double d = compose(sin, asin, 0.5);
	label1.setText(d.toString(9));
}


( ( compose
  =   f g
    . !arg:(?f.?g)&'(.($f)$(($g)$!arg))
  )
&     compose
    $ ( (=.flt$(!arg,2))
      . compose$((=.!arg*5/9).(=.!arg+-32))
      )
  : (=?FahrenheitToCelsius)
& ( FahrenheitToCelsiusExample
  =   deg
    .   chu$(x2d$b0):?deg
      &   out
        $ ( str
          $ (!arg " " !deg "F in " !deg "C = " FahrenheitToCelsius$!arg)
          )
  )
& FahrenheitToCelsiusExample$0
& FahrenheitToCelsiusExample$100
)


compose = { f, g | { x | f g x } }

#Test
add1 = { x | x + 1 }
double = { x | x * 2 }
b = compose(->double ->add1)
p b 1 #should print 4


#include <stdlib.h>

/* generic interface for functors from double to double */
typedef struct double_to_double {
  double (*fn)(struct double_to_double *, double);
} double_to_double;

#define CALL(f, x) f->fn(f, x)

/* functor returned by compose */
typedef struct compose_functor {
  double (*fn)(struct compose_functor *, double);
  double_to_double *f;
  double_to_double *g;
} compose_functor;
/* function to be used in "fn" in preceding functor */
double compose_call(compose_functor *this, double x) {
  return CALL(this->f, CALL(this->g, x));
}
/* returns functor that is the composition of functors
   f & g. caller is responsible for deallocating memory */
double_to_double *compose(double_to_double *f,
                          double_to_double *g) {
  compose_functor *result = malloc(sizeof(compose_functor));
  result->fn = &compose_call;
  result->f = f;
  result->g = g;
  return (double_to_double *)result;
}

#include <math.h>

/* we can make functors for sin and asin by using
   the following as "fn" in a functor */
double sin_call(double_to_double *this, double x) {
  return sin(x);
}
double asin_call(double_to_double *this, double x) {
  return asin(x);
}

#include <stdio.h>

int main() {
  double_to_double *my_sin = malloc(sizeof(double_to_double));
  my_sin->fn = &sin_call;
  double_to_double *my_asin = malloc(sizeof(double_to_double));
  my_asin->fn = &asin_call;

  double_to_double *sin_asin = compose(my_sin, my_asin);

  printf("%f\n", CALL(sin_asin, 0.5)); /* prints "0.500000" */

  free(sin_asin);
  free(my_sin);
  free(my_asin);

  return 0;
}


using System;
class Program
{
    static void Main(string[] args)
    {
        Func<int, int> outfunc = Composer<int, int, int>.Compose(functA, functB);
        Console.WriteLine(outfunc(5)); //Prints 100
    }
    static int functA(int i) { return i * 10; }
    static int functB(int i) { return i + 5; }
    class Composer<A, B, C>
    {
        public static Func<C, A> Compose(Func<B, A> a, Func<C, B> b)
        {
            return delegate(C i) { return a(b(i)); };
        }
    }
}


#include <functional>
#include <cmath>
#include <iostream>

// functor class to be returned by compose function
template <class Fun1, class Fun2>
class compose_functor :
  public std::unary_function<typename Fun2::argument_type,
                             typename Fun1::result_type>
{
protected:
  Fun1 f;
  Fun2 g;

public:
  compose_functor(const Fun1& _f, const Fun2& _g)
    : f(_f), g(_g) { }

  typename Fun1::result_type
  operator()(const typename Fun2::argument_type& x) const
  { return f(g(x)); }
};

// we wrap it in a function so the compiler infers the template arguments
// whereas if we used the class directly we would have to specify them explicitly
template <class Fun1, class Fun2>
inline compose_functor<Fun1, Fun2>
compose(const Fun1& f, const Fun2& g)
{ return compose_functor<Fun1,Fun2>(f, g); }

int main() {
  std::cout << compose(std::ptr_fun(::sin), std::ptr_fun(::asin))(0.5) << std::endl;

  return 0;
}


(defn compose [f g]
  (fn [x]
    (f (g x))))

; Example
(def inc2 (compose inc inc))
(println (inc2 5)) ; prints 7


compose = ( f, g ) -> ( x ) -> f g x

# Example
add2 = ( x ) -> x + 2
mul2 = ( x ) -> x * 2

mulFirst = compose add2, mul2
addFirst = compose mul2, add2
multiple = compose mul2, compose add2, mul2

console.log "add2 2 #=> #{ add2 2 }"
console.log "mul2 2 #=> #{ mul2 2 }"
console.log "mulFirst 2 #=> #{ mulFirst 2 }"
console.log "addFirst 2 #=> #{ addFirst 2 }"
console.log "multiple 2 #=> #{ multiple 2 }"


(defun compose (f g) (lambda (x) (funcall f (funcall g x))))


require "math"

def compose(f : Proc(T, _), g : Proc(_, _)) forall T
  return ->(x : T) { f.call(g.call(x)) }
end

compose(->Math.sin(Float64), ->Math.asin(Float64)).call(0.5)  #=> 0.5


import std.stdio;

T delegate(S) compose(T, U, S)(in T delegate(U) f,
                               in U delegate(S) g) {
    return s => f(g(s));
}

void main() {
    writeln(compose((int x) => x + 15, (int x) => x ^^ 2)(10));
    writeln(compose((int x) => x ^^ 2, (int x) => x + 15)(10));
}


program AnonCompose;

{$APPTYPE CONSOLE}

type
  TFunc = reference to function(Value: Integer): Integer;
  // Alternative: TFunc = TFunc<Integer,Integer>;

function Compose(F, G: TFunc): TFunc;
begin
  Result:= function(Value: Integer): Integer
  begin
    Result:= F(G(Value));
  end
end;

var
  Func1, Func2, Func3: TFunc;

begin
  Func1:=
    function(Value: Integer): Integer
    begin
      Result:= Value * 2;
    end;

  Func2:=
    function(Value: Integer): Integer
    begin
      Result:= Value * 3;
    end;

  Func3:= Compose(Func1, Func2);

  Writeln(Func3(6));    // 36 = 6 * 3 * 2
  Readln;
end.


set_namespace(rosettacode);

begin_funct(compose)_arg(f, g);
    []_ret(x)_calc([f]([g]([x])));
end_funct[];

me_msg()_funct(compose)_arg(f)_sin()_arg(g)_asin()_var(x)_value(0.5);    // result: 0.5

reset_namespace[];


define method compose(f,g)
   method(x) f(g(x)) end
end;


def compose(f, g) {
  return fn x { return f(g(x)) }
}


;; By decreasing order of performance
;; 1) user definition : lambda and closure

(define (ucompose f g ) (lambda (x) ( f ( g x))))
(ucompose sin cos)
   → (🔒 λ (_x) (f (g _x)))

;; 2) built-in compose : lambda

(compose sin cos)
   → (λ (_#:g1002) (#apply-compose (#list #cos #sin) _#:g1002))

;; 3) compiled composition

(define (sincos x) (sin (cos x)))
sincos → (λ (_x) (⭕ #sin (#cos _x)))


import extensions;

extension op : Func1
{
    compose(Func1 f)
        = (x => self(f(x)));
}

public program()
{
    var fg := (x => x + 1).compose:(x => x * x);

    console.printLine(fg(3))
}


defmodule RC do
  def compose(f, g), do: fn(x) -> f.(g.(x)) end

  def multicompose(fs), do: List.foldl(fs, fn(x) -> x end, &compose/2)
end

sin_asin = RC.compose(&:math.sin/1, &:math.asin/1)
IO.puts sin_asin.(0.5)

IO.puts RC.multicompose([&:math.sin/1, &:math.asin/1, fn x->1/x end]).(0.5)
IO.puts RC.multicompose([&(&1*&1), &(1/&1), &(&1*&1)]).(0.5)


;; lexical-binding: t
(defun compose (f g)
  (lambda (x)
    (funcall f (funcall g x))))

(let ((func (compose '1+ '1+)))
  (funcall func 5)) ;=> 7


-module(fn).
-export([compose/2, multicompose/1]).

compose(F,G) -> fun(X) -> F(G(X)) end.

multicompose(Fs) ->
    lists:foldl(fun compose/2, fun(X) -> X end, Fs).


> let compose f g x = f (g x);;

val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b


( scratchpad ) [ 2 * ] [ 1 + ] compose .
[ 2 * 1 + ]
( scratchpad ) 4 [ 2 * ] [ 1 + ] compose call .
9


class Compose
{
  static |Obj -> Obj| compose (|Obj -> Obj| fn1, |Obj -> Obj| fn2)
  {
    return |Obj x -> Obj| { fn2 (fn1 (x)) }
  }

  public static Void main ()
  {
    double := |Int x -> Int| { 2 * x }
    |Int -> Int| quad := compose(double, double)
    echo ("Double 3 = ${double(3)}")
    echo ("Quadruple 3 = ${quad (3)}")
  }
}


: compose ( xt1 xt2 -- xt3 )
  >r >r :noname
     r> compile,
     r> compile,
     postpone ;
;

' 2* ' 1+ compose  ( xt )
3 swap execute .   \ 7


module functions_module
   implicit none
   private ! all by default
   public :: f,g

contains

   pure function  f(x)
      implicit none
      real, intent(in) :: x
      real :: f
      f = sin(x)
   end function f

   pure function  g(x)
      implicit none
      real, intent(in) :: x
      real :: g
      g = cos(x)
   end function g

end module functions_module

module compose_module
   implicit none
   private ! all by default
   public :: compose

   interface
      pure function  f(x)
         implicit none
         real, intent(in) :: x
         real :: f
      end function f

      pure function  g(x)
         implicit none
         real, intent(in) :: x
         real :: g
      end function g
   end interface

contains

   impure function  compose(x, fi, gi)
      implicit none
      real, intent(in) :: x
      procedure(f), optional :: fi
      procedure(g), optional :: gi
      real :: compose

      procedure (f), pointer, save :: fpi => null()
      procedure (g), pointer, save :: gpi => null()

      if(present(fi) .and. present(gi))then
         fpi => fi
         gpi => gi
         compose = 0
         return
      endif

      if(.not. associated(fpi)) error stop "fpi"
      if(.not. associated(gpi)) error stop "gpi"

      compose = fpi(gpi(x))

   contains

   end function compose

end module compose_module

program test_compose
   use functions_module
   use compose_module
   implicit none
   write(*,*) "prepare compose:", compose(0.0, f,g)
   write(*,*) "run compose:", compose(0.5)
end program test_compose


  compose[\A, B, C\](f:A->B, g:B->C, i:Any): A->C = do
    f(g(i))
  end

  composed(i:RR64): RR64 = compose(sin, cos, i)


function compose( f as function(as integer) as integer,_
                  g as function(as integer) as integer,_
                  n as integer ) as integer
    return f(g(n))
end function


import math.{sin, asin}

def compose( f, g ) = x -> f( g(x) )

sin_asin = compose( sin, asin )

println( sin_asin(0.5) )


Composition := function(f, g)
    return x -> f(g(x));
end;

h := Composition(x -> x+1, x -> x*x);
h(5);
# 26


// Go doesn't have generics, but sometimes a type definition helps
// readability and maintainability.   This example is written to
// the following function type, which uses float64.
type ffType func(float64) float64

// compose function requested by task
func compose(f, g ffType) ffType {
    return func(x float64) float64 {
        return f(g(x))
    }
}


final times2 = { it * 2 }
final plus1 = { it + 1 }

final plus1_then_times2 = times2 << plus1
final times2_then_plus1 = times2 >> plus1

assert plus1_then_times2(3) == 8
assert times2_then_plus1(3) == 7


Prelude> let sin_asin = sin . asin
Prelude> sin_asin 0.5
0.49999999999999994


(defn compose [f g]
  (fn [x]
    (f (g x))))


   x @ f                      # use this syntax in Icon instead of the Unicon f(x) to call co-expressions
   every push(fL := [],!rfL)  # use this instead of reverse(fL) as the Icon reverse applies only to strings


public class Compose {

    // Java doesn't have function type so we define an interface
    // of function objects instead
    public interface Fun<A,B> {
        B call(A x);
    }

    public static <A,B,C> Fun<A,C> compose(final Fun<B,C> f, final Fun<A,B> g) {
        return new Fun<A,C>() {
            public C call(A x) {
                return f.call(g.call(x));
            }
        };
    }

    public static void main(String[] args) {
        Fun<Double,Double> sin = new Fun<Double,Double>() {
            public Double call(Double x) {
                return Math.sin(x);
            }
        };
        Fun<Double,Double> asin = new Fun<Double,Double>() {
            public Double call(Double x) {
                return Math.asin(x);
            }
        };

        Fun<Double,Double> sin_asin = compose(sin, asin);

        System.out.println(sin_asin.call(0.5)); // prints "0.5"
    }
}


function compose(f, g) {
  return function(x) {
    return f(g(x));
  };
}


# apply g first and then f
def compose(f; g): g | f;


include ..\Utilitys.tlhy

:*2 2 * ;
:++ 1 + ;
:composite swap exec swap exec ;

@++ @*2 3 composite ? { result: 7 }

"End " input


// version 1.0.6

fun f(x: Int): Int = x * x

fun g(x: Int): Int = x + 2

fun compose(f: (Int) -> Int,  g: (Int) -> Int): (Int) -> Int  = { f(g(it)) }

fun main(args: Array<String>) {
   val x  = 10
   println(compose(::f, ::g)(x))
}


{def compose
 {lambda {:f :g :x}
  {:f {:g :x}}}}
-> compose

{def funcA {lambda {:x} {* :x 10}}}
-> funcA

{def funcB {lambda {:x} {+ :x 5}}}
-> funcB

{def f {compose funcA funcB}}
-> f

{{f} 3}
-> 80


(defun compose (f g)
  (lambda (x)
    (funcall f
      (funcall g x))))

(defun compose (funcs)
  (lists:foldl #'compose/2
               (lambda (x) x)
               funcs))

(defun check ()
  (let* ((sin-asin (compose #'math:sin/1 #'math:asin/1))
         (expected (math:sin (math:asin 0.5)))
         (compose-result (funcall sin-asin 0.5)))
    (io:format '"Expected answer: ~p~n" (list expected))
    (io:format '"Answer with compose: ~p~n" (list compose-result))))


-- in some movie script
----------------------------------------
-- Composes 2 call-functions, returns a new call-function
-- @param {symbol|instance} f
-- @param {symbol|instance} g
-- @return {instance}
----------------------------------------
on compose (f, g)
  return script("Composer").new(f, g)
end


HAI 1.3

I HAS A fx, I HAS A gx

HOW IZ I composin YR f AN YR g
    fx R f, gx R g
    HOW IZ I composed YR x
        FOUND YR I IZ fx YR I IZ gx YR x MKAY MKAY
    IF U SAY SO
    FOUND YR composed
IF U SAY SO

HOW IZ I incin YR num
    FOUND YR SUM OF num AN 1
IF U SAY SO

HOW IZ I sqrin YR num
    FOUND YR PRODUKT OF num AN num
IF U SAY SO

I HAS A incsqrin ITZ I IZ composin YR incin AN YR sqrin MKAY
VISIBLE I IZ incsqrin YR 10 MKAY BTW, prints 101

I HAS A sqrincin ITZ I IZ composin YR sqrin AN YR incin MKAY
VISIBLE I IZ sqrincin YR 10 MKAY BTW, prints 121

KTHXBYE


function compose(f, g) return function(...) return f(g(...)) end end


Module CheckIt {
      Compose = lambda (f, g)->{
            =lambda f, g (x)->f(g(x))
      }
      Add5=lambda (x)->x+5
      Division2=lambda (x)->x/2
      Add5Div2=compose(Division2, Add5)
      Print Add5Div2(15)=10  ' True
}
CheckIt


Composition[f, g][x]
Composition[f, g, h, i][x]


/* built-in */
load(to_poly_solver);

compose_functions([sin, cos]);
/* lambda([%g0],sin(cos(%g0)))*/

/* An implementation, to show a use of buildq */
compose(f, g) := buildq([f, g], lambda([x], f(g(x))));


funcA = function(x)
    return x * 10
end function

funcB = function(x)
    return x + 5
end function

compose = function(f, g)
    return function(x)
        return f(g(x))
    end function
end function

f = compose(@funcA, @funcB)
print f(3)  // should be equal to (3+5)*10


using System;
using System.Console;
using System.Math;

module Composition
{
    Compose[T](f : T -> T, g : T -> T, x : T) : T
    {
        f(g(x))
    }

    Main() : void
    {
        def SinAsin = Compose(Sin, Asin, _);
        WriteLine(SinAsin(0.5));
    }
}


func compose(f(i : int) -> int, g(i : int) -> int) -> (int) -> int
{
    let func (i : int) -> int { f(g(i)) }
}

func dec(i : int) -> int { 10 * i }

func succ(i : int) -> int { i + 1 }

func main() -> int
{
    let h = compose(dec, succ);

    print(h(1));

    0
}


> (define (compose f g) (expand (lambda (x) (f (g x))) 'f 'g))
(lambda (f g) (expand (lambda (x) (f (g x))) 'f 'g))
> ((compose sin asin) 0.5)
0.5


import sugar

proc compose[A,B,C](f: A -> B, g: B -> C): A -> C = (x: A) => f(g(x))

proc plustwo(x: int): int = x + 2
proc minustwo(x: int): int = x - 2

var plusminustwo = compose(plustwo, minustwo)
echo plusminustwo(10)


bundle Default {
  class Test {
    @f : static : (Int) ~ Int;
    @g : static : (Int) ~ Int;

    function : Main(args : String[]) ~ Nil {
      compose := Composer(F(Int) ~ Int, G(Int) ~ Int);
      compose(13)->PrintLine();
    }

    function : F(a : Int) ~ Int {
      return a + 14;
    }

    function : G(a : Int) ~ Int {
      return a + 15;
    }

    function : Compose(x : Int) ~ Int {
      return @f(@g(x));
    }

    function : Composer(f : (Int) ~ Int, g : (Int) ~ Int) ~ (Int) ~ Int {
      @f := f;
      @g := g;
      return Compose(Int) ~ Int;
    }
  }
}


# -*- ObjectIcon -*-
#
# The Rosetta Code function composition task, in Object Icon.
# Composition will result in a co-expression.
#
# Object Icon co-expressions are closures: they share the local
# variables of the context in which they are created. In Arizona Icon,
# co-expressions obtain only the *values* of those variables. However,
# this difference, despite its significance, is not really important
# to the notion of composition.
#
# This example is adapted from the Unicon implementation of the
# task. To simplify the example, I have removed support for string
# invocations.
#

import io

procedure main (arglist)
  local f, g

  # f gets a co-expression that is a composition of three procedures.
  f := compose(append_exclamation, string_repeat, double_it)
  write([email protected])

  # g gets a co-expression that is a composition of a procedure and f.
  g := compose(string_repeat, f)
  write([email protected])
end

procedure double_it (n)
  return n + n
end

procedure string_repeat (x)
  return string(x) || string(x)
end

procedure append_exclamation (s)
  return s || "!"
end

procedure compose (rfL[])
    local x, f, saveSource, fL, cf

    every push(fL := [], !rfL)
    cf := create {
      saveSource := &source
      repeat {
        x := [email protected]
        saveSource := &source
        every f := !fL do {
          case type(f) of {
            "co-expression": x := [email protected]
            default: x := f(x)
          }
        }
      }
    }

    # Co-expressions often need to be "primed" before they can be
    # used.
    @cf

    return cf
end


#include <Foundation/Foundation.h>

typedef id (^Function)(id);

// a commodity for "encapsulating" double f(double)
typedef double (*func_t)(double);
Function encapsulate(func_t f) {
  return ^(id x) { return @(f([x doubleValue])); };
}

Function compose(Function a, Function b) {
  return ^(id x) { return a(b(x)); };
}

// functions outside...
double my_f(double x)
{
  return x+1.0;
}

double my_g(double x)
{
  return x*x;
}

int main()
{
  @autoreleasepool {

    Function f = encapsulate(my_f);
    Function g = encapsulate(my_g);

    Function composed = compose(f, g);

    printf("g(2.0) = %lf\n", [g(@2.0) doubleValue]);
    printf("f(2.0) = %lf\n", [f(@2.0) doubleValue]);
    printf("f(g(2.0)) = %lf\n", [composed(@2.0) doubleValue]);

  }
  return 0;
}


function r = compose(f, g)
  r = @(x) f(g(x));
endfunction

r = compose(@exp, @sin);
r(pi/3)


(define (compose f g)
   (lambda (x) (f (g x))))

;; or:

(define ((compose f g) x) (f (g x)))


#include <order/interpreter.h>

#define ORDER_PP_DEF_8comp ORDER_PP_FN( \
8fn(8F, 8G, 8fn(8X, 8ap(8F, 8ap(8G, 8X)))) )


declare
  fun {Compose F G}
     fun {$ X}
        {F {G X}}
     end
  end

  SinAsin = {Compose Float.sin Float.asin}
in
  {Show {SinAsin 0.5}}


compose(f, g)={
  x -> f(g(x))
};

compose(x->sin(x),x->cos(x)(1)


sub compose {
    my ($f, $g) = @_;

    sub {
        $f -> ($g -> (@_))
    };
}

use Math::Trig;
print compose(sub {sin $_[0]}, \&asin)->(0.5), "\n";


sequence ctable = {}

function compose(integer f, integer g)
    ctable = append(ctable,{f,g})
    return length(ctable)
end function

function call_composite(integer f, atom x)
integer g
    {f,g} = ctable[f]
    return call_func(f,{call_func(g,{x})})
end function

function plus1(atom x)
    return x+1
end function

function halve(atom x)
    return x/2
end function

constant m = compose(routine_id("halve"),routine_id("plus1"))

?call_composite(m,1)    -- displays 1
?call_composite(m,4)    -- displays 2.5


def *2 2 * enddef
def ++ 1 + enddef
def composite swap exec swap exec enddef

getid ++ getid *2 3 composite print /# result: 7 #/


<?php
function compose($f, $g) {
  return function($x) use ($f, $g) { return $f($g($x)); };
}

$trim_strlen = compose('strlen', 'trim');
echo $result = $trim_strlen(' Test '), "\n"; // prints 4
?>


(de compose (F G)
   (curry (F G) (X)
      (F (G X)) ) )


/compose { % f g -> { g f }
  [ 3 1 roll exch
  % procedures are not executed when encountered directly
  % insert an 'exec' after procedures, but not after operators
  1 index type /operatortype ne { /exec cvx exch } if
  dup type /operatortype ne { /exec cvx } if
  ] cvx
} def

/square { dup mul } def
/plus1  { 1 add } def
/sqPlus1 /square load /plus1 load compose def


function g ($x) {
    $x + $x
}
function f ($x) {
    $x*$x*$x
}
f (g 1)


:- use_module(lambda).

compose(F,G, FG) :-
	FG =  \X^Z^(call(G,X,Y), call(F,Y,Z)).


;Declare how our function looks like
Prototype.i Func(Arg.i)

; Make a procedure that composes any functions of type "Func"
Procedure Compose(*a.Func,*b.Func, x)
  ProcedureReturn *a(*b(x))
EndProcedure

; Just a procedure fitting "Func"
Procedure f(n)
  ProcedureReturn 2*n
EndProcedure

; Yet another procedure fitting "Func"
Procedure g(n)
  ProcedureReturn n+1
EndProcedure

;- Test it
X=Random(100)
Title$="With x="+Str(x)
Body$="Compose(f(),g(), x) ="+Str(Compose(@f(),@g(),X))
MessageRequester(Title$,Body$)


compose = lambda f, g: lambda x: f( g(x) )


(define compose
  F G -> (/. X
             (F (G X))))

((compose (+ 1) (+ 2)) 3)   \ (Outputs 6) \


  [ nested swap
    nested swap join ]  is compose ( g f --> [ )

  ( ----- demonstration ----- )

 ( create a named nest -- equivalent to a function )

  [ 2 * ]               is double  (   n --> n )

  ( "[ 4 + ]" is an unnamed nest
               -- equivalent to a lambda function. )

  ( "quoting" a nest with ' puts it on the stack
    rather than it being evaluated. "do" evaluates
    the top of stack.                              )

  19   ' double   ' [ 4 + ]   compose do echo


compose <- function(f,g) function(x) { f(g(x)) }
r <- compose(sin, cos)
print(r(.5))


(define (compose f g)
  (lambda (x) (f (g x))))


sub triple($n) { 3 * $n }
my &f = &triple ∘ &prefix:<-> ∘ { $^n + 2 };
say &f(5); # prints "-21".


rebol [
	Title: "Functional Composition"
	URL: http://rosettacode.org/wiki/Functional_Composition
]

; "compose" means something else in REBOL, therefore I use a 'compose-functions name.

compose-functions: func [
    {compose the given functions F and G}
    f [any-function!]
    g [any-function!]
] [
    func [x] compose [(:f) (:g) x]
]


compose: procedure;  parse arg f,g,x;    interpret  'return'  f"("  g'('  x  "))"

exit        /*control should never gets here,  but this was added just in case.*/


# Project : Function composition

sumprod = func1(:func2,2,3)
see sumprod + nl

func func1(func2,x,y)
        temp = call func2(x,y)
        res = temp + x + y
        return res

func func2(x,y)
        res = x * y
        return res


def compose(f,g)
  lambda {|x| f[g[x]]}
end
s = compose(Math.method(:sin), Math.method(:cos))
p s[0.5]  # => 0.769196354841008

# verify
p Math.sin(Math.cos(0.5))  # => 0.769196354841008


fn compose<'a,F,G,T,U,V>(f: F, g: G) -> Box<Fn(T) -> V + 'a>
    where F: Fn(U) -> V + 'a,
          G: Fn(T) -> U + 'a,
{
   Box::new(move |x| f(g(x)))
}


def compose[A](f: A => A, g: A => A) = { x: A => f(g(x)) }

def add1(x: Int) = x+1
val add2 = compose(add1, add1)


(define (compose f g) (lambda (x) (f (g x))))

;; or:

(define ((compose f g) x) (f (g x)))

;; or to compose an arbitrary list of 1 argument functions:

(define-syntax compose
  (lambda (x)
    (syntax-case x ()
      ((_) #'(lambda (y) y))
      ((_ f) #'f)
      ((_ f g h ...)  #'(lambda (y) (f ((compose g h ...) y)))))))


[| :x | x + 1] ** [| :x | x squared] applyTo: {3}


| composer fg |
composer := [ :f :g | [ :x | f value: (g value: x) ] ].
fg := composer value: [ :x | x + 1 ]
               value: [ :x | x * x ].

(fg value:3) displayNl.


func compose<A,B,C>(f: (B) -> C, g: (A) -> B) -> (A) -> C {
  return { f(g($0)) }
}

let sin_asin = compose(sin, asin)
println(sin_asin(0.5))


package require Tcl 8.5
namespace path {::tcl::mathfunc}

proc compose {f g} {
    list apply [list {f g x} {{*}$f [{*}$g $x]}] $f $g]
}

set sin_asin [compose sin asin]
{*}$sin_asin 0.5 ;# ==> 0.5
{*}[compose abs int] -3.14 ;# ==> 3


function compose<T, U, V> (fn1: (input: T) => U, fn2: (input: U) => V){
    return function(value: T) {
        return fn2(fn1(value))
    }
}

function size (s: string): number { return s.length; }

function isEven(x: number): boolean { return x % 2 === 0; }

const evenSize = compose(size, isEven);

console.log(evenSize("ABCD")) // true
console.log(evenSize("ABC")) // false


Print FUNC(_Compose (_f, _g, 3))
End

_Compose Param (3) : Return (FUNC([email protected](FUNC([email protected]([email protected])))))
_f Param (1) : Return ([email protected] + 1)
_g Param (1) : Return ([email protected] * 2)


compose() {
	eval "$1() { $3 | $2; }"
}

downvowel() { tr AEIOU aeiou; }
upcase() { tr a-z A-Z; }
compose c downvowel upcase
echo 'Cozy lummox gives smart squid who asks for job pen.' | c
# => CoZY LuMMoX GiVeS SMaRT SQuiD WHo aSKS FoR JoB PeN.


option explicit
class closure

	private composition

	sub compose( f1, f2 )
		composition = f2 & "(" & f1 & "(p1))"
	end sub

	public default function apply( p1 )
		apply = eval( composition )
	end function

	public property get formula
		formula = composition
	end property

end class


var compose = Fn.new { |f, g| Fn.new { |x| f.call(g.call(x)) } }

var double = Fn.new { |x| 2 * x }

var addOne = Fn.new { |x| x + 1 }

System.print(compose.call(double, addOne).call(3))


10 DEF FN f(x)=SQR x
20 DEF FN g(x)=ABS x
30 DEF FN c(x)=FN f(FN g(x))
40 PRINT FN c(-4)


#include <ctype.h>
#include <locale.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdint.h>
#include <glib.h>

typedef uint64_t integer;

typedef struct number_names_tag {
    const char* cardinal;
    const char* ordinal;
} number_names;

const number_names small[] = {
    { "zero", "zeroth" }, { "one", "first" }, { "two", "second" },
    { "three", "third" }, { "four", "fourth" }, { "five", "fifth" },
    { "six", "sixth" }, { "seven", "seventh" }, { "eight", "eighth" },
    { "nine", "ninth" }, { "ten", "tenth" }, { "eleven", "eleventh" },
    { "twelve", "twelfth" }, { "thirteen", "thirteenth" },
    { "fourteen", "fourteenth" }, { "fifteen", "fifteenth" },
    { "sixteen", "sixteenth" }, { "seventeen", "seventeenth" },
    { "eighteen", "eighteenth" }, { "nineteen", "nineteenth" }
};

const number_names tens[] = {
    { "twenty", "twentieth" }, { "thirty", "thirtieth" },
    { "forty", "fortieth" }, { "fifty", "fiftieth" },
    { "sixty", "sixtieth" }, { "seventy", "seventieth" },
    { "eighty", "eightieth" }, { "ninety", "ninetieth" }
};

typedef struct named_number_tag {
    const char* cardinal;
    const char* ordinal;
    integer number;
} named_number;

const named_number named_numbers[] = {
    { "hundred", "hundredth", 100 },
    { "thousand", "thousandth", 1000 },
    { "million", "millionth", 1000000 },
    { "billion", "biliionth", 1000000000 },
    { "trillion", "trillionth", 1000000000000 },
    { "quadrillion", "quadrillionth", 1000000000000000ULL },
    { "quintillion", "quintillionth", 1000000000000000000ULL }
};

const char* get_small_name(const number_names* n, bool ordinal) {
    return ordinal ? n->ordinal : n->cardinal;
}

const char* get_big_name(const named_number* n, bool ordinal) {
    return ordinal ? n->ordinal : n->cardinal;
}

const named_number* get_named_number(integer n) {
    const size_t names_len = sizeof(named_numbers)/sizeof(named_numbers[0]);
    for (size_t i = 0; i + 1 < names_len; ++i) {
        if (n < named_numbers[i + 1].number)
            return &named_numbers[i];
    }
    return &named_numbers[names_len - 1];
}

typedef struct word_tag {
    size_t offset;
    size_t length;
} word_t;

typedef struct word_list_tag {
    GArray* words;
    GString* str;
} word_list;

void word_list_create(word_list* words) {
    words->words = g_array_new(FALSE, FALSE, sizeof(word_t));
    words->str = g_string_new(NULL);
}

void word_list_destroy(word_list* words) {
    g_string_free(words->str, TRUE);
    g_array_free(words->words, TRUE);
}

void word_list_clear(word_list* words) {
    g_string_truncate(words->str, 0);
    g_array_set_size(words->words, 0);
}

void word_list_append(word_list* words, const char* str) {
    size_t offset = words->str->len;
    size_t len = strlen(str);
    g_string_append_len(words->str, str, len);
    word_t word;
    word.offset = offset;
    word.length = len;
    g_array_append_val(words->words, word);
}

word_t* word_list_get(word_list* words, size_t index) {
    return &g_array_index(words->words, word_t, index);
}

void word_list_extend(word_list* words, const char* str) {
    word_t* word = word_list_get(words, words->words->len - 1);
    size_t len = strlen(str);
    word->length += len;
    g_string_append_len(words->str, str, len);
}

size_t append_number_name(word_list* words, integer n, bool ordinal) {
    size_t count = 0;
    if (n < 20) {
        word_list_append(words, get_small_name(&small[n], ordinal));
        count = 1;
    } else if (n < 100) {
        if (n % 10 == 0) {
            word_list_append(words, get_small_name(&tens[n/10 - 2], ordinal));
        } else {
            word_list_append(words, get_small_name(&tens[n/10 - 2], false));
            word_list_extend(words, "-");
            word_list_extend(words, get_small_name(&small[n % 10], ordinal));
        }
        count = 1;
    } else {
        const named_number* num = get_named_number(n);
        integer p = num->number;
        count += append_number_name(words, n/p, false);
        if (n % p == 0) {
            word_list_append(words, get_big_name(num, ordinal));
            ++count;
        } else {
            word_list_append(words, get_big_name(num, false));
            ++count;
            count += append_number_name(words, n % p, ordinal);
        }
    }
    return count;
}

size_t count_letters(word_list* words, size_t index) {
    const word_t* word = word_list_get(words, index);
    size_t letters = 0;
    const char* s = words->str->str + word->offset;
    for (size_t i = 0, n = word->length; i < n; ++i) {
        if (isalpha((unsigned char)s[i]))
            ++letters;
    }
    return letters;
}

void sentence(word_list* result, size_t count) {
    static const char* words[] = {
        "Four", "is", "the", "number", "of", "letters", "in", "the",
        "first", "word", "of", "this", "sentence,"
    };
    word_list_clear(result);
    size_t n = sizeof(words)/sizeof(words[0]);
    for (size_t i = 0; i < n; ++i)
        word_list_append(result, words[i]);
    for (size_t i = 1; count > n; ++i) {
        n += append_number_name(result, count_letters(result, i), false);
        word_list_append(result, "in");
        word_list_append(result, "the");
        n += 2;
        n += append_number_name(result, i + 1, true);
        // Append a comma to the final word
        word_list_extend(result, ",");
    }
}

size_t sentence_length(const word_list* words) {
    size_t n = words->words->len;
    if (n == 0)
        return 0;
    return words->str->len + n - 1;
}

int main() {
    setlocale(LC_ALL, "");
    size_t n = 201;
    word_list result = { 0 };
    word_list_create(&result);
    sentence(&result, n);
    printf("Number of letters in first %'lu words in the sequence:\n", n);
    for (size_t i = 0; i < n; ++i) {
        if (i != 0)
            printf("%c", i % 25 == 0 ? '\n' : ' ');
        printf("%'2lu", count_letters(&result, i));
    }
    printf("\nSentence length: %'lu\n", sentence_length(&result));
    for (n = 1000; n <= 10000000; n *= 10) {
        sentence(&result, n);
        const word_t* word = word_list_get(&result, n - 1);
        const char* s = result.str->str + word->offset;
        printf("The %'luth word is '%.*s' and has %lu letters. ", n,
               (int)word->length, s, count_letters(&result, n - 1));
        printf("Sentence length: %'lu\n" , sentence_length(&result));
    }
    word_list_destroy(&result);
    return 0;
}


#include <cctype>
#include <cstdint>
#include <iomanip>
#include <iostream>
#include <string>
#include <vector>

struct number_names {
    const char* cardinal;
    const char* ordinal;
};

const number_names small[] = {
    { "zero", "zeroth" }, { "one", "first" }, { "two", "second" },
    { "three", "third" }, { "four", "fourth" }, { "five", "fifth" },
    { "six", "sixth" }, { "seven", "seventh" }, { "eight", "eighth" },
    { "nine", "ninth" }, { "ten", "tenth" }, { "eleven", "eleventh" },
    { "twelve", "twelfth" }, { "thirteen", "thirteenth" },
    { "fourteen", "fourteenth" }, { "fifteen", "fifteenth" },
    { "sixteen", "sixteenth" }, { "seventeen", "seventeenth" },
    { "eighteen", "eighteenth" }, { "nineteen", "nineteenth" }
};

const number_names tens[] = {
    { "twenty", "twentieth" }, { "thirty", "thirtieth" },
    { "forty", "fortieth" }, { "fifty", "fiftieth" },
    { "sixty", "sixtieth" }, { "seventy", "seventieth" },
    { "eighty", "eightieth" }, { "ninety", "ninetieth" }
};

struct named_number {
    const char* cardinal;
    const char* ordinal;
    uint64_t number;
};

const named_number named_numbers[] = {
    { "hundred", "hundredth", 100 },
    { "thousand", "thousandth", 1000 },
    { "million", "millionth", 1000000 },
    { "billion", "biliionth", 1000000000 },
    { "trillion", "trillionth", 1000000000000 },
    { "quadrillion", "quadrillionth", 1000000000000000ULL },
    { "quintillion", "quintillionth", 1000000000000000000ULL }
};

const char* get_name(const number_names& n, bool ordinal) {
    return ordinal ? n.ordinal : n.cardinal;
}

const char* get_name(const named_number& n, bool ordinal) {
    return ordinal ? n.ordinal : n.cardinal;
}

const named_number& get_named_number(uint64_t n) {
    constexpr size_t names_len = std::size(named_numbers);
    for (size_t i = 0; i + 1 < names_len; ++i) {
        if (n < named_numbers[i + 1].number)
            return named_numbers[i];
    }
    return named_numbers[names_len - 1];
}

size_t append_number_name(std::vector<std::string>& result, uint64_t n, bool ordinal) {
    size_t count = 0;
    if (n < 20) {
        result.push_back(get_name(small[n], ordinal));
        count = 1;
    }
    else if (n < 100) {
        if (n % 10 == 0) {
            result.push_back(get_name(tens[n/10 - 2], ordinal));
        } else {
            std::string name(get_name(tens[n/10 - 2], false));
            name += "-";
            name += get_name(small[n % 10], ordinal);
            result.push_back(name);
        }
        count = 1;
    } else {
        const named_number& num = get_named_number(n);
        uint64_t p = num.number;
        count += append_number_name(result, n/p, false);
        if (n % p == 0) {
            result.push_back(get_name(num, ordinal));
            ++count;
        } else {
            result.push_back(get_name(num, false));
            ++count;
            count += append_number_name(result, n % p, ordinal);
        }
    }
    return count;
}

size_t count_letters(const std::string& str) {
    size_t letters = 0;
    for (size_t i = 0, n = str.size(); i < n; ++i) {
        if (isalpha(static_cast<unsigned char>(str[i])))
            ++letters;
    }
    return letters;
}

std::vector<std::string> sentence(size_t count) {
    static const char* words[] = {
        "Four", "is", "the", "number", "of", "letters", "in", "the",
        "first", "word", "of", "this", "sentence,"
    };
    std::vector<std::string> result;
    result.reserve(count + 10);
    size_t n = std::size(words);
    for (size_t i = 0; i < n && i < count; ++i) {
        result.push_back(words[i]);
    }
    for (size_t i = 1; count > n; ++i) {
        n += append_number_name(result, count_letters(result[i]), false);
        result.push_back("in");
        result.push_back("the");
        n += 2;
        n += append_number_name(result, i + 1, true);
        result.back() += ',';
    }
    return result;
}

size_t sentence_length(const std::vector<std::string>& words) {
    size_t n = words.size();
    if (n == 0)
        return 0;
    size_t length = n - 1;
    for (size_t i = 0; i < n; ++i)
        length += words[i].size();
    return length;
}

int main() {
    std::cout.imbue(std::locale(""));
    size_t n = 201;
    auto result = sentence(n);
    std::cout << "Number of letters in first " << n << " words in the sequence:\n";
    for (size_t i = 0; i < n; ++i) {
        if (i != 0)
            std::cout << (i % 25 == 0 ? '\n' : ' ');
        std::cout << std::setw(2) << count_letters(result[i]);
    }
    std::cout << '\n';
    std::cout << "Sentence length: " << sentence_length(result) << '\n';
    for (n = 1000; n <= 10000000; n *= 10) {
        result = sentence(n);
        const std::string& word = result[n - 1];
        std::cout << "The " << n << "th word is '" << word << "' and has "
            << count_letters(word) << " letters. ";
        std::cout << "Sentence length: " << sentence_length(result) << '\n';
    }
    return 0;
}


package main

import (
	"fmt"
	"strings"
	"unicode"
)

func main() {
	f := NewFourIsSeq()
	fmt.Print("The lengths of the first 201 words are:")
	for i := 1; i <= 201; i++ {
		if i%25 == 1 {
			fmt.Printf("\n%3d: ", i)
		}
		_, n := f.WordLen(i)
		fmt.Printf(" %2d", n)
	}
	fmt.Println()
	fmt.Println("Length of sentence so far:", f.TotalLength())
	/* For debugging:
	log.Println("sentence:", strings.Join(f.words, " "))
	for i, w := range f.words {
		log.Printf("%3d: %2d %q\n", i, countLetters(w), w)
	}
	log.Println(f.WordLen(2202))
	log.Println("len(f.words):", len(f.words))
	log.Println("sentence:", strings.Join(f.words, " "))
	*/
	for i := 1000; i <= 1e7; i *= 10 {
		w, n := f.WordLen(i)
		fmt.Printf("Word %8d is %q, with %d letters.", i, w, n)
		fmt.Println("  Length of sentence so far:", f.TotalLength())
	}
}

type FourIsSeq struct {
	i     int      // index of last word processed
	words []string // strings.Join(words," ") gives the sentence so far
}

func NewFourIsSeq() *FourIsSeq {
	return &FourIsSeq{
		//words: strings.Fields("Four is the number of letters in the first word of this sentence,"),
		words: []string{
			"Four", "is", "the", "number",
			"of", "letters", "in", "the",
			"first", "word", "of", "this", "sentence,",
		},
	}
}

// WordLen returns the w'th word and its length (only counting letters).
func (f *FourIsSeq) WordLen(w int) (string, int) {
	for len(f.words) < w {
		f.i++
		n := countLetters(f.words[f.i])
		ns := say(int64(n))
		os := sayOrdinal(int64(f.i+1)) + ","
		// append something like: "two in the second,"
		f.words = append(f.words, strings.Fields(ns)...)
		f.words = append(f.words, "in", "the")
		f.words = append(f.words, strings.Fields(os)...)
	}
	word := f.words[w-1]
	return word, countLetters(word)
}

// TotalLength returns the total number of characters (including blanks,
// commas, and punctuation) of the sentence so far constructed.
func (f FourIsSeq) TotalLength() int {
	cnt := 0
	for _, w := range f.words {
		cnt += len(w) + 1
	}
	return cnt - 1
}

func countLetters(s string) int {
	cnt := 0
	for _, r := range s {
		if unicode.IsLetter(r) {
			cnt++
		}
	}
	return cnt
}

// ...
// the contents of
// https://rosettacode.org/wiki/Spelling_of_ordinal_numbers#Go
// omitted from this listing
// ...