var count = 0
var c = []
var f = []

var nQueens // recursive
nQueens = Fn.new { |row, n|
    for (x in 1..n) {
        var outer = false
        var y = 1
        while (y < row) {
            if ((c[y] == x) || (row - y == (x -c[y]).abs)) {
                outer = true
                break
            }
            y = y + 1
        }
        if (!outer) {
            c[row] = x
            if (row < n) {
                nQueens.call(row + 1, n)
            } else {
                count = count + 1
                if (count == 1) f = c.skip(1).map { |i| i - 1 }.toList
            }
        }
    }
}

for (n in 1..14) {
    count = 0
    c = List.filled(n+1, 0)
    f = []
    nQueens.call(1, n)
    System.print("For a %(n) x %(n) board:")
    System.print("  Solutions = %(count)")
    if (count > 0) System.print("  First is %(f)")
    System.print()
}


int abs(i: int) {
    if (i >= 0) return i; else return -i;
}

unit print_dots(n: int) {
  while (n > 0) { print_string("."); n = n - 1; }
  return;
}

{size:int | 0 < size}
unit print_board (board[size]: int, size: int(size)) {
  var: int n, row;;

  invariant: [i:nat] (row: int(i))
  for (row = 0; row < size; row = row + 1) {
    n = board[row];
    print_dots(n-1);
    print_string("Q");
    print_dots(size - n);
    print_newline();
  }
    print_newline();
    return;
}

{size:int, j:int | 0 <= j < size}
bool test (j: int(j), board[size]: int) {
  var: int diff, i, qi, qj;;

  qj = board[j];

  invariant: [i:nat] (i: int(i))
  for (i = 0; i < j; i = i + 1) {
    qi = board[i]; diff = abs (qi - qj);
    if (diff == 0) { return false; }
    else { if (diff == j - i) return false; }
  }
  return true;
}

{size:int | 0 < size}
nat queen(size: int(size)) {
  var: int board[], next, row; nat count;;

  count = 0; row = 0; board = alloc(size, 0);

  invariant: [n:nat | n < size] (row: int(n))
  while (true) {
    next = board[row]; next = next + 1;
    if (next > size) {
      if (row == 0) break; else { board[row] = 0; row = row - 1; }
    } else {
      board[row] = next;
      if (test(row, board)) {
        row = row + 1;
        if (row == size) {
          count = count + 1;
	  print_board(board, size);
          row = row - 1;
        }
      }
    }
  }
  return count;
}

int main () {
  return queen (8);
}


def     N=8;    \board size (NxN)
int     R, C;   \row and column of board
char    B(N,N); \board
include c:\cxpl\codes;

proc Try;       \Try adding a queen to the board
int  R;         \row, for each level of recursion

    func Okay;
    \Returns 'true' if no row, column, or diagonal from square R,C has a queen
    int I;
    [for I:= 0 to N-1 do
        [if B(I,C) then return false;                   \row is occupied
        if B(R,I) then return false;                    \column is occupied
        if R+I<N & C+I<N then
                if B(R+I, C+I) then return false;       \diagonal down right
        if R-I>=0 & C-I>=0 then
                if B(R-I, C-I) then return false;       \diagonal up left
        if R-I>=0 & C+I<N then
                if B(R-I, C+I) then return false;       \diagonal up right
        if R+I<N & C-I>=0 then
                if B(R+I, C-I) then return false;       \diagonal down left
        ];
    return true;
    ]; \Okay

[ \Try
if C>=N then
        [for R:= 0 to N-1 do                            \display solution
            [ChOut(0, ^ ); \(avoids scrolling up a color)
            for C:= 0 to N-1 do
                [Attrib(if (R|C)&1 then $0F else $4F);  \checkerboard pattern
                ChOut(6, if B(R,C) then $F2 else ^ );   \cute queen symbol
                ChOut(6, if B(R,C) then $F3 else ^ );
                ];
            CrLf(0);
            ];
        exit;                                           \one solution is enough
        ];
for R:= 0 to N-1 do
    [if Okay(R,C) then          \a queen can be placed here
        [B(R,C):= true;         \ so do it
        C:= C+1;                \move to next column
        Try;                    \ and try from there
        C:= C-1;                \didn't work: backup
        B(R,C):= false;         \undo queen placement
        ];
    ];
]; \Try

[for R:= 0 to N-1 do            \clear the board
    for C:= 0 to N-1 do
        B(R,C):= false;
C:= 0;                          \start at left column
Try;
]


DOCU The N Queens Problem:
DOCU Place N Queens on an NxN chess board
DOCU such that they don't threaten each other.

N = 8 // try some other sizes

sub threat(q1r, q1c, q2r, q2c)
// do two queens threaten each other?

   if q1c = q2c then    return true
   elsif (q1r - q1c) = (q2r - q2c) then return true
   elsif (q1r + q1c) = (q2r + q2c) then return true
   elsif q1r = q2r then    return true
   else return false
   end if
end sub

sub conflict(r, c, queens$)
// Would square p cause a conflict with other queens on board so far?
   local r2, c2

   for i = 1 to len(queens$) step 2
       r2 = val(mid$(queens$,i,1))
       c2 = val(mid$(queens$,i+1,1))
       if threat(r, c, r2, c2) then
            return true
       end if
    next i
   return false
end sub

sub print_board(queens$)
// print a solution, showing the Queens on the board
   local k$

   print at(1, 1);
   print "Solution #", soln, "\n\n   ";
   for c = asc("a") to (asc("a") + N - 1)
        print chr$(c)," ";
   next c
   print
   for r = 1 to N
        print r using "##"," ";
        for c = 1 to N
            pos = instr(queens$, (str$(r)+str$(c)))
            if pos and mod(pos, 2) then
                queens$ = mid$(queens$,pos)
                print "Q ";
            else
                print ". ";
            end if
        next c
        print
    next r
    print "\nPress Enter. (q to quit) "
    while(true)
        k$ = inkey$
        if lower$(k$) = "q" then
           exit
        elsif k$ = "enter" then
           break
        end if
    wend
end sub


const std = @import("std");
const stdout = std.io.getStdOut().outStream();

var board = [_]i8{-1} ** 8;

inline fn abs(x: var) @TypeOf(x) {
    return if (x < 0) -x else x;
}

fn safe(c: i32, r: i32) bool {
    var i: i32 = 0;
    return while (i < c) : (i += 1) {
        const q = board[@intCast(u3, i)];
        if (r == q or c == i + abs(q - r))
            break false;
    } else true;
}

pub fn main() !void {
    var i: i32 = 0;
    while (i >= 0) {
        var j = board[@intCast(u3, i)] + 1;
        while (j < 8) : (j += 1) {
            if (safe(i, j)) {
                board[@intCast(u3, i)] = j;
                i += 1;
                break;
            }
        } else {
            board[@intCast(u3, i)] = -1;
            i -= 1;
        }
        if (i == 8) { // found a solution
            for (board) |q|
                try stdout.print("{} ", .{q + 1});
            try stdout.print("\n", .{});
            i -= 1; // create a failure to try new solutions.
        }
    }
}


fcn isAttacked(q, x,y) // ( (r,c), x,y ) : is queen at r,c attacked by [email protected](x,y)?
   { r,c:=q; (r==x or c==y or r+c==x+y or r-c==x-y) }
fcn isSafe(r,c,qs) // queen safe at (r,c)?, qs=( (r,c),(r,c)..) solution so far
   { ( not qs.filter1(isAttacked,r,c) ) }
fcn queensN(N=8,row=1,queens=T){
   qs:=[1..N].filter(isSafe.fpM("101",row,queens)) #isSafe(row,?,( (r,c),(r,c).. )
       .apply(fcn(c,r,qs){ qs.append(T(r,c)) },row,queens);
   if (row == N) return(qs);
   return(qs.apply(self.fcn.fp(N,row+1)).flatten());
}


F modifier(Float x) -> Float
   R I x < 0.5 {2 * (.5 - x)} E 2 * (x - .5)

F modified_random_distribution((Float -> Float) modifier, Int n) -> [Float]
   [Float] d
   L d.len < n
      V prob = random:()
      I random:() < modifier(prob)
         d.append(prob)
   R d

V data = modified_random_distribution(modifier, 50'000)
V bins = 15
DefaultDict[Int, Int] counts
L(d) data
   counts[d I/ (1 / bins)]++

V mx = max(counts.values())
print("   BIN, COUNTS, DELTA: HISTOGRAM\n")
Float? last
L(b, count) sorted(counts.items())
   V delta = I last == N {‘N/A’} E String(count - last)
   print(‘  #2.2,  #4,  #4: ’.format(Float(b) / bins, count, delta)‘’(‘#’ * Int(40 * count / mx)))
   last = count


with Ada.Text_Io;
with Ada.Numerics.Float_Random;
with Ada.Strings.Fixed;

procedure Modified_Distribution is

   Observations : constant := 20_000;
   Buckets      : constant := 25;
   Divider      : constant := 12;
   Char         : constant Character := '*';

   generic
      with function Modifier (X : Float) return Float;
   package Generic_Random is
      function Random return Float;
   end Generic_Random;

   package body Generic_Random is
      package Float_Random renames Ada.Numerics.Float_Random;
      Generator : Float_Random.Generator;

      function Random return Float is
         Random_1 : Float;
         Random_2 : Float;
      begin
         loop
            Random_1 := Float_Random.Random (Generator);
            Random_2 := Float_Random.Random (Generator);
            if Random_2 < Modifier (Random_1) then
               return Random_1;
            end if;
         end loop;
      end Random;

   begin
     Float_Random.Reset (Generator);
   end Generic_Random;

   generic
      Buckets : in Positive;
   package Histograms is
      type Bucket_Index is new Positive range 1 .. Buckets;
      Bucket_Width : constant Float := 1.0 / Float (Buckets);
      procedure Clean;
      procedure Increment_Bucket (Observation : Float);
      function Observations_In (Bucket : Bucket_Index) return Natural;
      function To_Bucket (X : Float) return Bucket_Index;
      function Range_Image (Bucket : Bucket_Index) return String;
   end Histograms;

   package body Histograms is
      Hist : array (Bucket_Index) of Natural := (others => 0);

      procedure Clean is
      begin
         Hist := (others => 0);
      end Clean;

      procedure Increment_Bucket (Observation : Float) is
         Bin : constant Bucket_Index := To_Bucket (Observation);
      begin
         Hist (Bin) := Hist (Bin) + 1;
      end Increment_Bucket;

      function Observations_In (Bucket : Bucket_Index) return Natural
      is (Hist (Bucket));

      function To_Bucket (X : Float) return Bucket_Index
      is (1 + Bucket_Index'Base (Float'Floor (X / Bucket_Width)));

      function Range_Image (Bucket : Bucket_Index) return String is
         package Float_Io is new Ada.Text_Io.Float_Io (Float);
         Image : String := "F.FF..L.LL";
         First : constant Float := Float (Bucket - 1) / Float (Buckets);
         Last  : constant Float := Float (Bucket - 1 + 1) / Float (Buckets);
      begin
         Float_Io.Put (Image (1 .. 4),  First, Exp => 0, Aft => 2);
         Float_Io.Put (Image (7 .. 10), Last,  Exp => 0, Aft => 2);
         return Image;
      end Range_Image;

   begin
      Clean;
   end Histograms;

   function Modifier (X : Float) return Float
   is (if X in Float'First .. 0.5
       then 2.0 * (0.5 - X)
       else 2.0 * (X - 0.5));

   package Modified_Random is
     new Generic_Random (Modifier => Modifier);

   package Histogram_20 is
     new Histograms (Buckets => Buckets);

   function Column (Height : Natural; Char : Character) return String
     renames Ada.Strings.Fixed."*";

   use Ada.Text_Io;
begin
   for N in 1 .. Observations loop
      Histogram_20.Increment_Bucket (Modified_Random.Random);
   end loop;

   Put ("Range      Observations: "); Put (Observations'Image);
   Put ("  Buckets: "); Put (Buckets'Image);
   New_Line;
   for I in Histogram_20.Bucket_Index'Range loop
      Put (Histogram_20.Range_Image (I));
      Put (" ");
      Put (Column (Histogram_20.Observations_In (I) / Divider, Char));
      New_Line;
   end loop;
end Modified_Distribution;


USING: assocs assocs.extras formatting io kernel math
math.functions math.statistics random sequences
tools.memory.private ;

: modifier ( x -- y ) 0.5 over 0.5 < [ swap ] when - dup + ;

: random-unit-by ( quot: ( x -- y ) -- z )
    random-unit dup pick call random-unit 2dup >
    [ 2drop nip ] [ 3drop random-unit-by ] if ; inline recursive

: data ( n quot bins -- histogram )
    '[ _ random-unit-by _ * >integer ] replicate histogram ;
    inline

:: .histogram ( h -- )

    h assoc-size :> buckets   ! number of buckets
    h sum-values :> total     ! items in histogram
    h values supremum :> max  ! largest bucket (as in most occurrences)
    40 :> size                ! max size of a bar

    total commas buckets
    "Bin          Histogram (%s items, %d buckets)\n" printf

    h [| k v |
        k buckets / dup buckets recip + "[%.2f, %.2f) " printf
        size v * max / ceiling
        [ "▇" write ] times bl bl v commas print
    ] assoc-each ;

"Modified random distribution of values in [0, 1):" print nl
100,000 [ modifier ] 20 data .histogram


#define NRUNS 100000
#define NBINS 20

function modifier( x as double ) as double
    return iif(x < 0.5, 2*(0.5 - x), 2*(x - 0.5))
end function

function modrand() as double
    dim as double random1, random2
    do
        random1 = rnd
        random2 = rnd
        if random2 < modifier(random1) then
            return random1
        endif
    loop
end function

function histo( byval bn as uinteger ) as string
    dim as double db = NRUNS/(50*NBINS)
    dim as string h
    while bn > db:
        h = h + "#"
        bn -= db
    wend
    return h

end function

dim as uinteger bins(0 to NBINS-1), i, b
dim as double db = 1./NBINS, rand

randomize timer

for i = 1 to NRUNS
    rand = modrand()
    b = int(rand/db)
    bins(b) += 1
next i

for b = 0 to NBINS-1
    print using "Bin ## (#.## to #.##): & ####";b;b*db;(b+1)*db;histo(bins(b));bins(b)
next b


package main

import (
    "fmt"
    "math"
    "math/rand"
    "strings"
    "time"
)

func rng(modifier func(x float64) float64) float64 {
    for {
        r1 := rand.Float64()
        r2 := rand.Float64()
        if r2 < modifier(r1) {
            return r1
        }
    }
}

func commatize(n int) string {
    s := fmt.Sprintf("%d", n)
    if n < 0 {
        s = s[1:]
    }
    le := len(s)
    for i := le - 3; i >= 1; i -= 3 {
        s = s[0:i] + "," + s[i:]
    }
    if n >= 0 {
        return s
    }
    return "-" + s
}

func main() {
    rand.Seed(time.Now().UnixNano())
    modifier := func(x float64) float64 {
        if x < 0.5 {
            return 2 * (0.5 - x)
        }
        return 2 * (x - 0.5)
    }
    const (
        N              = 100000
        NUM_BINS       = 20
        HIST_CHAR      = "■"
        HIST_CHAR_SIZE = 125
    )
    bins := make([]int, NUM_BINS) // all zero by default
    binSize := 1.0 / NUM_BINS
    for i := 0; i < N; i++ {
        rn := rng(modifier)
        bn := int(math.Floor(rn / binSize))
        bins[bn]++
    }

    fmt.Println("Modified random distribution with", commatize(N), "samples in range [0, 1):\n")
    fmt.Println("    Range           Number of samples within that range")
    for i := 0; i < NUM_BINS; i++ {
        hist := strings.Repeat(HIST_CHAR, int(math.Round(float64(bins[i])/HIST_CHAR_SIZE)))
        fi := float64(i)
        fmt.Printf("%4.2f ..< %4.2f  %s %s\n", binSize*fi, binSize*(fi+1), hist, commatize(bins[i]))
    }
}


import System.Random
import Data.List
import Text.Printf

modify :: Ord a => (a -> a) -> [a] -> [a]
modify f = foldMap test . pairs
  where
    pairs lst = zip lst (tail lst)
    test (r1, r2) = if r2 < f r1 then [r1] else []

vShape x = if x < 0.5 then 2*(0.5-x) else 2*(x-0.5)

hist b lst = zip [0,b..] res
  where
    res = (`div` sum counts) . (*300) <$> counts
    counts = map length $ group $
             sort $ floor . (/b) <$> lst

showHist h = foldMap mkLine h
  where
    mkLine (b,n) = printf "%.2f\t%s %d%%\n" b (replicate n '▇') n


probmod=: {{y
  while.do.r=.?0 0
    if. (<u)/r do. {:r return.end.
  end.
}}

mod=: {{|1-2*y}}


using UnicodePlots

modifier(x) = (y = 2x - 1; y < 0 ? -y : y)
modrands(rands1, rands2) = [x for (i, x) in enumerate(rands1) if rands2[i] < modifier(x)]
histogram(modrands(rand(50000), rand(50000)), nbins = 20)


ClearAll[Modifier, CreateRandomNumber]
Modifier[x_] := If[x < 0.5, 2 (0.5 - x), 2 (x - 0.5)]
CreateRandomNumber[] := Module[{r1, r2, done = True},
  While[done,
   r1 = RandomReal[];
   r2 = RandomReal[];
   If[r2 < Modifier[r1],
    Return[r1];
    done = False
    ]
   ]
  ]
numbers = Table[CreateRandomNumber[], 100000];
{bins, counts} = HistogramList[numbers, {0, 1, 0.05}, "PDF"];
Grid[MapThread[{#1, " - ", [email protected]["X", Round[20 #2]]} &, {Partition[bins, 2, 1], counts}], Alignment -> Left]


import random, strformat, strutils, sugar

type ValRange = range[0.0..1.0]

func modifier(x: ValRange): ValRange =
  if x < 0.5: 2 * (0.5 - x) else: 2 * (x - 0.5)

proc rand(modifier: (float) -> float): ValRange =
  while true:
    let r1 = rand(1.0)
    let r2 = rand(1.0)
    if r2 < modifier(r1):
      return r1

const
  N = 100_000
  NumBins = 20
  HistChar = "■"
  HistCharSize = 125
  BinSize = 1 / NumBins

randomize()

var bins: array[NumBins, int]
for i in 0..<N:
  let rn = rand(modifier)
  let bn = int(rn / BinSize)
  inc bins[bn]

echo &"Modified random distribution with {N} samples in range [0, 1):"
echo "    Range           Number of samples within that range"
for i in 0..<NumBins:
  let hist = repeat(HistChar, (bins[i] / HistCharSize).toInt)
  echo &"{BinSize * float(i):4.2f} ..< {BinSize * float(i + 1):4.2f}  {hist} {bins[i]}"


use strict;
use warnings;
use List::Util 'max';

sub distribution {
    my %param = ( function => \&{scalar sub {return 1}}, sample_size => 1e5, @_);
    my @values;
    do {
        my($r1, $r2) = (rand, rand);
        push @values, $r1 if &{$param{function}}($r1) > $r2;
    } until @values == $param{sample_size};
    wantarray ? @values : \@values;
}

sub modifier_notch {
    my($x) = @_;
    return 2 * ( $x < 1/2 ? ( 1/2 - $x  )
                          : ( $x  - 1/2 ) );
}

sub print_histogram {
    our %param = (n_bins => 10, width => 80, @_);
    my %counts;
    $counts{ int($_ * $param{n_bins}) / $param{n_bins} }++ for @{$param{data}};
    our $max_value = max values %counts;
    print "Bin  Counts  Histogram\n";
    printf "%4.2f %6d: %s\n", $_, $counts{$_}, hist($counts{$_}) for sort keys %counts;
    sub hist { scalar ('■') x ( $param{width} * $_[0] / $max_value ) }
}

print_histogram( data => \@{ distribution() } );
print "\n\n";

my @samples = distribution( function => \&modifier_notch, sample_size => 50_000);
print_histogram( data => \@samples, n_bins => 20, width => 64);


function rng(integer modifier)
    while true do
        atom r1 := rnd()
        if rnd() < modifier(r1) then
            return r1
        end if
    end while
end function

function modifier(atom x)
    return iff(x < 0.5 ? 2 * (0.5 - x)
                       : 2 * (x - 0.5))
end function

constant N              = 100000,
         NUM_BINS       = 20,
         HIST_CHAR_SIZE = 125,
         BIN_SIZE       = 1/NUM_BINS,
         LO = sq_mul(tagset(NUM_BINS-1,0),BIN_SIZE),
         HI = sq_mul(tagset(NUM_BINS),BIN_SIZE),
         LBLS = apply(true,sprintf,{{"[%4.2f,%4.2f)"},columnize({LO,HI})})

sequence bins := repeat(0, NUM_BINS)
for i=1 to N do
    bins[floor(rng(modifier) / BIN_SIZE)+1] += 1
end for

printf(1,"Modified random distribution with %,d samples in range [0, 1):\n\n",N)
for i=1 to NUM_BINS do
    sequence hist := repeat('#', round(bins[i]/HIST_CHAR_SIZE))
    printf(1,"%s  %s %,d\n", {LBLS[i], hist, bins[i]})
end for


import random
from typing import List, Callable, Optional

def modifier(x: float) -> float:
    """
    V-shaped, modifier(x) goes from 1 at 0 to 0 at 0.5 then back to 1 at 1.0 .

    Parameters
    ----------
    x : float
        Number, 0.0 .. 1.0 .

    Returns
    -------
    float
        Target probability for generating x; between 0 and 1.

    """
    return 2*(.5 - x) if x < 0.5 else 2*(x - .5)

def modified_random_distribution(modifier: Callable[[float], float],
                                 n: int) -> List[float]:
    """
    Generate n random numbers between 0 and 1 subject to modifier.

    Parameters
    ----------
    modifier : Callable[[float], float]
        Target random number gen. 0 <= modifier(x) < 1.0 for 0 <= x < 1.0 .
    n : int
        number of random numbers generated.

    Returns
    -------
    List[float]
        n random numbers generated with given probability.

    """
    d: List[float] = []
    while len(d) < n:
        r1 = prob = random.random()
        if random.random() < modifier(prob):
            d.append(r1)
    return d

if __name__ == '__main__':
    from collections import Counter

    data = modified_random_distribution(modifier, 50_000)
    bins = 15
    counts = Counter(d // (1 / bins) for d in data)
    #
    mx = max(counts.values())
    print("   BIN, COUNTS, DELTA: HISTOGRAM\n")
    last: Optional[float] = None
    for b, count in sorted(counts.items()):
        delta = 'N/A' if last is None else str(count - last)
        print(f"  {b / bins:5.2f},  {count:4},  {delta:>4}: "
              f"{'#' * int(40 * count / mx)}")
        last = count


library(NostalgiR) #For the textual histogram.
modifier <- function(x) 2*abs(x - 0.5)
gen <- function()
{
  repeat
  {
    random <- runif(2)
    if(random[2] < modifier(random[1])) return(random[1])
  }
}
data <- replicate(100000, gen())
NostalgiR::nos.hist(data, breaks = 20, pch = "#")


/*REXX program generates a "<" shaped probability of number generation using a modifier.*/
parse arg randn bins seed .                      /*obtain optional argument from the CL.*/
if randN=='' | randN==","  then randN= 100000    /*Not specified?  Then use the default.*/
if  bins=='' |  bins==","  then  bins=     20    /* "      "         "   "   "     "    */
if datatype(seed, 'W')   then call random ,,seed /* "      "         "   "   "     "    */
call MRD
!.= 0
      do j=1  for randN;   bin= @.j*bins%1
      !.bin= !.bin + 1                           /*bump the applicable bin counter.     */
      end   /*j*/
mx= 0
      do k=1  for randN;   mx= max(mx, !.k)      /*find the maximum, used for histograph*/
      end   /*k*/

say '  bin'
say '────── '   center('(with '    commas(randN)    " samples",  80 - 10)

       do b=0  for bins;  say format(b/bins,2,2)   copies('■', 70*!.b%mx)" "   commas(!.b)
       end   /*b*/
exit 0
/*──────────────────────────────────────────────────────────────────────────────────────*/
commas:   arg ?;  do jc=length(?)-3  to 1  by -3;  ?=insert(',', ?, jc);  end;    return ?
rand:     return random(0, 100000) / 100000
/*──────────────────────────────────────────────────────────────────────────────────────*/
modifier: parse arg y;   if y<.5  then return  2 * (.5 -  y)
                                  else return  2 * ( y - .5)
/*──────────────────────────────────────────────────────────────────────────────────────*/
MRD:      #=0;                      @.=          /*MRD:  Modified Random distribution.  */
            do until #==randN;      r= rand()    /*generate a random number; assign bkup*/
            if rand()>=modifier(r)  then iterate /*Doesn't meet requirement?  Then skip.*/
            #= # + 1;               @.#= r       /*bump counter; assign the MRD to array*/
            end   /*until*/
          return


sub modified_random_distribution ( Code $modifier --> Seq ) {
    return lazy gather loop {
        my ( $r1, $r2 ) = rand, rand;
        take $r1 if $modifier.($r1) > $r2;
    }
}
sub modifier ( Numeric $x --> Numeric ) {
    return 2 * ( $x < 1/2 ?? ( 1/2 - $x  )
                          !! ( $x  - 1/2 ) );
}
sub print_histogram ( @data, :$n-bins, :$width ) { # Assumes minimum of zero.
    my %counts = bag @data.map: { floor( $_ * $n-bins ) / $n-bins };
    my $max_value = %counts.values.max;
    sub hist { '■' x ( $width * $^count / $max_value ) }
    say ' Bin, Counts: Histogram';
    printf "%4.2f, %6d: %s\n", .key, .value, hist(.value) for %counts.sort;
}

my @d = modified_random_distribution( &modifier );

print_histogram( @d.head(50_000), :n-bins(20), :width(64) );


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

var rgen = Random.new()

var rng = Fn.new { |modifier|
    while (true) {
        var r1 = rgen.float()
        var r2 = rgen.float()
        if (r2 < modifier.call(r1)) {
            return r1
        }
    }
}

var modifier = Fn.new { |x| (x < 0.5) ? 2 * (0.5 - x) : 2 * (x - 0.5) }

var N = 100000
var NUM_BINS = 20
var HIST_CHAR = "■"
var HIST_CHAR_SIZE = 125
var bins = List.filled(NUM_BINS, 0)
var binSize = 1 / NUM_BINS
for (i in 0...N) {
    var rn = rng.call(modifier)
    var bn = (rn / binSize).floor
    bins[bn] = bins[bn] + 1
}

Fmt.print("Modified random distribution with $,d samples in range [0, 1):\n", N)
System.print("    Range           Number of samples within that range")
for (i in 0...NUM_BINS) {
    var hist = HIST_CHAR * (bins[i] / HIST_CHAR_SIZE).round
    Fmt.print("$4.2f ..< $4.2f  $s $,d", binSize * i, binSize * (i + 1), hist, bins[i])
}


\ return "extended gcd" of a and b; The result satisfies the equation:
\     a*x + b*y = gcd(a,b)
: n:xgcd \ a b --  gcd x y
  dup 0 n:= if
    1 swap            \ -- a 1 0
  else
    tuck n:/mod
    -rot recurse
    tuck 4 roll
    n:* n:neg n:+
  then ;

\ Return modular inverse of n modulo mod, or null if it doesn't exist (n and mod
\ not coprime):
: n:invmod \ n mod -- invmod
  dup >r
  n:xgcd rot 1 n:= not if
    2drop null
  else
    drop dup 0 n:< if [email protected] n:+ then
  then
  rdrop ;

42 2017 n:invmod . cr bye


INT FUNC ModInverse(INT a,b)
  INT t,nt,r,nr,q,tmp

  IF b<0 THEN b=-b FI
  IF a<0 THEN a=b-(-a MOD b) FI
  t=0 nt=1
  r=b nr=a MOD b
  WHILE nr#0
  DO
    q=r/nr
    tmp=nt nt=t-q*nt t=tmp
    tmp=nr nr=r-q*nr r=tmp
  OD
  IF r>1 THEN
    RETURN (-1)
  FI
  IF t<0 THEN
    t==+b
  FI
RETURN (t)

PROC Test(INT a,b)
  INT res

  res=ModInverse(a,b)
  IF res>=0 THEN
    PrintF("%I MODINV %I=%I%E",a,b,res)
  ELSE
    PrintF("%I MODINV %I has no result%E",a,b)
  FI
RETURN

PROC Main()
  Test(42,2017)
  Test(40,1)
  Test(52,-217)
  Test(-486,217)
  Test(40,2018)
RETURN


with Ada.Text_IO;use Ada.Text_IO;
procedure modular_inverse is
  -- inv_mod calculates the inverse of a mod n. We should have n>0 and, at the end, the contract is a*Result=1 mod n
  -- If this is false then we raise an exception (don't forget the -gnata option when you compile
  function inv_mod (a : Integer; n : Positive) return Integer with post=> (a * inv_mod'Result) mod n = 1 is
    -- To calculate the inverse we do as if we would calculate the GCD with the Euclid extended algorithm
    -- (but we just keep the coefficient on a)
    function inverse (a, b, u, v : Integer) return Integer is
     (if b=0 then u else inverse (b, a mod b, v, u-(v*a)/b));
  begin
    return inverse (a, n, 1, 0);
  end inv_mod;
begin
  -- This will output -48 (which is correct)
  Put_Line (inv_mod (42,2017)'img);
  -- The further line will raise an exception since the GCD will not be 1
  Put_Line (inv_mod (42,77)'img);
  exception when others => Put_Line ("The inverse doesn't exist.");
end modular_inverse;


BEGIN
   PROC modular inverse = (INT a, m) INT :
   BEGIN
      PROC extended gcd = (INT x, y) []INT :
CO
   Algol 68 allows us to return three INTs in several ways.  A [3]INT
   is used here but it could just as well be a STRUCT.
CO
      BEGIN
	 INT v := 1, a := 1, u := 0, b := 0, g := x, w := y;
	 WHILE w>0
	 DO
	    INT q := g % w, t := a - q * u;
	    a := u; u := t;
	    t := b - q * v;
	    b := v; v := t;
	    t := g - q * w;
	    g := w; w := t
	 OD;
	 a PLUSAB (a < 0 | u | 0);
	 (a, b, g)
      END;
      [] INT egcd = extended gcd (a, m);
      (egcd[3] > 1 | 0 | egcd[1] MOD m)
   END;
   printf (($"42 ^ -1 (mod 2017) = ", g(0)$, modular inverse (42, 2017)))
CO
   Note that if ϕ(m) is known, then a^-1 = a^(ϕ(m)-1) mod m which
   allows an alternative implementation in terms of modular
   exponentiation but, in general, this requires the factorization of
   m.  If m is prime the factorization is trivial and ϕ(m) = m-1.
   2017 is prime which may, or may not, be ironic within the context
   of the Rosetta Code conditions.
CO
END


modInverse: function [a,b][
    if b = 1 -> return 1

    b0: b   x0: 0   x1: 1
    z: a

    while [z > 1][
        q: z / b        t: b
        b: z % b        z: t
        t: x0           x0: x1 - q * x0
        x1: t
    ]
    (x1 < 0) ? -> x1 + b0
               -> x1
]

print modInverse 42 2017


# syntax: GAWK -f MODULAR_INVERSE.AWK
# converted from C
BEGIN {
    printf("%s\n",mod_inv(42,2017))
    exit(0)
}
function mod_inv(a,b,  b0,t,q,x0,x1) {
    b0 = b
    x0 = 0
    x1 = 1
    if (b == 1) {
      return(1)
    }
    while (a > 1) {
      q = int(a / b)
      t = b
      b = int(a % b)
      a = t
      t = x0
      x0 = x1 - q * x0
      x1 = t
    }
    if (x1 < 0) {
      x1 += b0
    }
    return(x1)
}


REM Modular inverse
E = 42
T = 2017
GOSUB CalcModInv:
PRINT ModInv
END

CalcModInv:
REM Increments E Step times until Bal is greater than T
REM Repeats until Bal = 1 (MOD = 1) and returns Count
REM Bal will not be greater than T + E
D = 0
IF E < T THEN
  Bal = E
  Count = 1
  Loop:
    Step = T - Bal
    Step = Step / E
    Step = Step + 1
    REM So ... Step = (T - Bal) / E + 1
    StepTimesE = Step * E
    Bal = Bal + StepTimesE
    Count = Count + Step
    Bal = Bal - T
    IF Bal <> 1 THEN Loop:
  D = Count
ENDIF
ModInv = D
RETURN


@echo off
setlocal enabledelayedexpansion
	%== Calls the "function" ==%
call :ModInv 42 2017 result
echo !result!
call :ModInv 40 1 result
echo !result!
call :ModInv 52 -217 result
echo !result!
call :ModInv -486 217 result
echo !result!
call :ModInv 40 2018 result
echo !result!
pause>nul
exit /b 0

	%== The "function" ==%
:ModInv
	set a=%1
	set b=%2

	if !b! lss 0 (set /a b=-b)
	if !a! lss 0 (set /a a=b - ^(-a %% b^))

	set t=0&set nt=1&set r=!b!&set /a nr=a%%b

	:while_loop
	if !nr! neq 0 (
		set /a q=r/nr
		set /a tmp=nt
		set /a nt=t - ^(q*nt^)
		set /a t=tmp

		set /a tmp=nr
		set /a nr=r - ^(q*nr^)
		set /a r=tmp
		goto while_loop
	)

	if !r! gtr 1 (set %3=-1&goto :EOF)
	if !t! lss 0 set /a t+=b
	set %3=!t!
	goto :EOF


get "libhdr"

let mulinv(a, b) =
    b<0 -> mulinv(a, -b),
    a<0 -> mulinv(b - (-a rem b), b),
    valof
    $(  let t, nt, r, nr = 0, 1, b, a rem b
        until nr = 0
        $(  let tmp, q = ?, r / nr
            tmp := nt ; nt := t - q*nt ; t := tmp
            tmp := nr ; nr := r - q*nr ; r := tmp
        $)
        resultis r>1 -> -1,
                 t<0 -> t + b,
                 t
    $)

let show(a, b) be
$(  let mi = mulinv(a, b)
    test mi>=0
        do writef("%N, %N -> %N*N", a, b, mi)
        or writef("%N, %N -> no inverse*N", a, b)
$)

let start() be
$(  show(42, 2017)
    show(40, 1)
    show(52, -217)
    show(-486, 217)
    show(40, 2018)
$)


#include <stdio.h>

int mul_inv(int a, int b)
{
	int b0 = b, t, q;
	int x0 = 0, x1 = 1;
	if (b == 1) return 1;
	while (a > 1) {
		q = a / b;
		t = b, b = a % b, a = t;
		t = x0, x0 = x1 - q * x0, x1 = t;
	}
	if (x1 < 0) x1 += b0;
	return x1;
}

int main(void) {
	printf("%d\n", mul_inv(42, 2017));
	return 0;
}


public class Program
{
    static void Main()
    {
        System.Console.WriteLine(42.ModInverse(2017));
    }
}

public static class IntExtensions
{
    public static int ModInverse(this int a, int m)
    {
        if (m == 1) return 0;
        int m0 = m;
        (int x, int y) = (1, 0);

        while (a > 1) {
            int q = a / m;
            (a, m) = (m, a % m);
            (x, y) = (y, x - q * y);
        }
        return x < 0 ? x + m0 : x;
    }
}


#include <iostream>

int mul_inv(int a, int b)
{
	int b0 = b, t, q;
	int x0 = 0, x1 = 1;
	if (b == 1) return 1;
	while (a > 1) {
		q = a / b;
		t = b, b = a % b, a = t;
		t = x0, x0 = x1 - q * x0, x1 = t;
	}
	if (x1 < 0) x1 += b0;
	return x1;
}

int main(void) {
	std::cout << mul_inv(42, 2017) << std::endl;
	return 0;
}


(ns test-p.core
  (:require [clojure.math.numeric-tower :as math]))

(defn extended-gcd
  "The extended Euclidean algorithm--using Clojure code from RosettaCode for Extended Eucliean
  (see http://en.wikipedia.orwiki/Extended_Euclidean_algorithm)
  Returns a list containing the GCD and the Bézout coefficients
  corresponding to the inputs with the result: gcd followed by bezout coefficients "
  [a b]
  (cond (zero? a) [(math/abs b) 0 1]
        (zero? b) [(math/abs a) 1 0]
        :else (loop [s 0
                     s0 1
                     t 1
                     t0 0
                     r (math/abs b)
                     r0 (math/abs a)]
                (if (zero? r)
                  [r0 s0 t0]
                  (let [q (quot r0 r)]
                    (recur (- s0 (* q s)) s
                           (- t0 (* q t)) t
                           (- r0 (* q r)) r))))))

(defn mul_inv
  " Get inverse using extended gcd.  Extended GCD returns
    gcd followed by bezout coefficients. We want the 1st coefficients
   (i.e. second of extend-gcd result).  We compute mod base so result
    is between 0..(base-1) "
  [a b]
  (let [b (if (neg? b) (- b) b)
        a (if (neg? a) (- b (mod (- a) b)) a)
        egcd (extended-gcd a b)]
      (if (= (first egcd) 1)
        (mod (second egcd) b)
        (str "No inverse since gcd is: " (first egcd)))))

(println (mul_inv 42 2017))
(println (mul_inv 40 1))
(println (mul_inv 52 -217))
(println (mul_inv -486 217))
(println (mul_inv 40 2018))


mul_inv = proc (a, b: int) returns (int) signals (no_inverse)
    if b<0 then b := -b end
    if a<0 then a := b - (-a // b) end
    t: int := 0
    nt: int := 1
    r: int := b
    nr: int := a // b
    while nr ~= 0 do
        q: int := r / nr
        t, nt := nt, t - q*nt
        r, nr := nr, r - q*nr
    end
    if r>1 then signal no_inverse end
    if t<0 then t := t+b end
    return(t)
end mul_inv

start_up = proc ()
    pair = struct[a, b: int]
    tests: sequence[pair] := sequence[pair]$
       [pair${a: 42, b: 2017},
        pair${a: 40, b: 1},
        pair${a: 52, b: -217},
        pair${a: -486, b: 217},
        pair${a: 40, b: 2018}]

    po: stream := stream$primary_output()
    for test: pair in sequence[pair]$elements(tests) do
        stream$puts(po, int$unparse(test.a) || ", "
                     || int$unparse(test.b) || " -> ")
        stream$putl(po, int$unparse(mul_inv(test.a, test.b)))
        except when no_inverse:
            stream$putl(po, "no modular inverse")
        end
    end
end start_up


;;
;; Calculates the GCD of a and b based on the Extended Euclidean Algorithm. The function also returns
;; the Bézout coefficients s and t, such that gcd(a, b) = as + bt.
;;
;; The algorithm is described on page http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm#Iterative_method_2
;;
(defun egcd (a b)
  (do ((r (cons b a) (cons (- (cdr r) (* (car r) q)) (car r))) ; (r+1 r) i.e. the latest is first.
       (s (cons 0 1) (cons (- (cdr s) (* (car s) q)) (car s))) ; (s+1 s)
       (u (cons 1 0) (cons (- (cdr u) (* (car u) q)) (car u))) ; (t+1 t)
       (q nil))
      ((zerop (car r)) (values (cdr r) (cdr s) (cdr u)))       ; exit when r+1 = 0 and return r s t
    (setq q (floor (/ (cdr r) (car r))))))                     ; inside loop; calculate the q

;;
;; Calculates the inverse module for a = 1 (mod m).
;;
;; Note: The inverse is only defined when a and m are coprimes, i.e. gcd(a, m) = 1.”
;;
(defun invmod (a m)
  (multiple-value-bind (r s k) (egcd a m)
    (unless (= 1 r) (error "invmod: Values ~a and ~a are not coprimes." a m))
     s))


include "cowgol.coh";

sub mulinv(a: int32, b: int32): (t: int32) is
    if b<0 then b := -b; end if;
    if a<0 then a := b - (-a % b); end if;
    t := 0;
    var nt: int32 := 1;
    var r := b;
    var nr := a % b;
    while nr != 0 loop
        var q := r / nr;
        var tmp := nt; nt := t - q*nt; t := tmp;
        tmp := nr; nr := r - q*nr; r := tmp;
    end loop;
    if r>1 then t := -1;
    elseif t<0 then t := t + b;
    end if;
end sub;

record Pair is
    a: int32;
    b: int32;
end record;

var data: Pair[] := {
    {42, 2017},
    {40, 1},
    {52, -217},
    {-486, 217},
    {40, 2018}
};

var i: @indexof data := 0;
while i < @sizeof data loop
    print_i32(data[i].a as uint32);
    print(", ");
    print_i32(data[i].b as uint32);
    print(" -> ");
    var mi := mulinv(data[i].a, data[i].b);
    if mi<0
        then print("no inverse");
        else print_i32(mi as uint32);
    end if;
    print_nl();
    i := i + 1;
end loop;


def modinv(a0, m0)
  return 1 if m0 == 1
  a, m = a0, m0
  x0, inv = 0, 1
  while a > 1
    inv -= (a // m) * x0
    a, m = m, a % m
    x0, inv = inv, x0
  end
  inv += m0 if inv < 0
  inv
end


T modInverse(T)(T a, T b) pure nothrow {
    if (b == 1)
        return 1;
    T b0 = b,
      x0 = 0,
      x1 = 1;

    while (a > 1) {
        immutable q = a / b;
        auto t = b;
        b = a % b;
        a = t;
        t = x0;
        x0 = x1 - q * x0;
        x1 = t;
    }
    return (x1 < 0) ? (x1 + b0) : x1;
}

void main() {
    import std.stdio;
    writeln(modInverse(42, 2017));
}


proc mulinv(int a, b) int:
    int t, nt, r, nr, q, tmp;
    if b<0 then b := -b fi;
    if a<0 then a := b - (-a % b) fi;
    t := 0; nt := 1; r := b; nr := a % b;
    while nr /= 0 do
        q := r / nr;
        tmp := nt; nt := t - q*nt; t := tmp;
        tmp := nr; nr := r - q*nr; r := tmp
    od;
    if r>1 then -1
    elif t<0 then t+b
    else t
    fi
corp

proc show(int a, b) void:
    int mi;
    mi := mulinv(a, b);
    if mi>=0
        then writeln(a:5, ", ", b:5, " -> ", mi:5)
        else writeln(a:5, ", ", b:5, " -> no inverse")
    fi
corp

proc main() void:
    show(42, 2017);
    show(40, 1);
    show(52, -217);
    show(-486, 217);
    show(40, 2018)
corp


(lib 'math) ;; for egcd = extended gcd

(define (mod-inv x m)
    (define-values (g inv q) (egcd x m))
    (unless (= 1 g) (error 'not-coprimes (list x m) ))
    (if (< inv 0) (+ m inv) inv))

(mod-inv 42 2017)  → 1969
(mod-inv 42 666)
🔴 error: not-coprimes (42 666)


defmodule Modular do
  def extended_gcd(a, b) do
    {last_remainder, last_x} = extended_gcd(abs(a), abs(b), 1, 0, 0, 1)
    {last_remainder, last_x * (if a < 0, do: -1, else: 1)}
  end

  defp extended_gcd(last_remainder, 0, last_x, _, _, _), do: {last_remainder, last_x}
  defp extended_gcd(last_remainder, remainder, last_x, x, last_y, y) do
    quotient   = div(last_remainder, remainder)
    remainder2 = rem(last_remainder, remainder)
    extended_gcd(remainder, remainder2, x, last_x - quotient*x, y, last_y - quotient*y)
  end

  def inverse(e, et) do
      {g, x} = extended_gcd(e, et)
      if g != 1, do: raise "The maths are broken!"
      rem(x+et, et)
    end
  end

IO.puts Modular.inverse(42,2017)


PROGRAM MOD_INV

!$INTEGER

PROCEDURE MUL_INV(A,B->T)
  LOCAL NT,R,NR,Q,TMP
  IF B<0 THEN B=-B
  IF A<0 THEN A=B-(-A MOD B)
  T=0  NT=1  R=B  NR=A MOD B
  WHILE NR<>0 DO
      Q=R DIV NR
      TMP=NT  NT=T-Q*NT  T=TMP
      TMP=NR  NR=R-Q*NR  R=TMP
  END WHILE
  IF (R>1) THEN T=-1 EXIT PROCEDURE  ! NO INVERSE
  IF (T<0) THEN T+=B
END PROCEDURE

BEGIN
     MUL_INV(42,2017->T) PRINT(T)
     MUL_INV(40,1->T) PRINT(T)
     MUL_INV(52,-217->T) PRINT(T)    ! pari semantics for negative modulus
     MUL_INV(-486,217->T)  PRINT(T)
     MUL_INV(40,2018->T) PRINT(T)
END PROGRAM


// Calculate the inverse of a (mod m)
// See here for eea specs:
// https://en.wikipedia.org/wiki/Extended_Euclidean_algorithm
let modInv m a =
  let rec eea t t' r r' =
    match r' with
    | 0 -> t
    | _ ->
      let div = r/r'
      eea t' (t - div * t') r' (r - div * r')
  (m + eea 0 1 m a) % m


: invmod { a m | v b c -- inv }
  m to v
  1 to c
  0 to b
  begin a
  while v a / >r
     c b s>d c s>d [email protected] 1 m*/ d- d>s to c to b
     a v s>d a s>d r> 1 m*/ d- d>s to a to v
  repeat b m mod dup to b 0<
  if m b + else b then ;


' version 10-07-2018
' compile with: fbc -s console

Type ext_euclid
    Dim As Integer a, b
End Type

' "Table method" aka "The Magic Box"
Function magic_box(x As Integer, y As Integer) As ext_euclid

    Dim As Integer a(1 To 128), b(1 To 128), d(1 To 128), k(1 To 128)

    a(1) = 1 : b(1) = 0 : d(1) = x
    a(2) = 0 : b(2) = 1 : d(2) = y : k(2) = x \ y

    Dim As Integer i = 2

    While Abs(d(i)) <> 1
        i += 1
        a(i) = a(i -2) - k(i -1) * a(i -1)
        b(i) = b(i -2) - k(i -1) * b(i -1)
        d(i) = d(i -2) Mod d(i -1)
        k(i) = d(i -1) \ d(i)
        'Print a(i),b(i),d(i),k(i)
        If d(i -1) Mod d(i) = 0 Then Exit While
    Wend

    If d(i) = -1 Then '  -1 * (ab + by) = -1 * -1 ==> -ab -by = 1
        a(i) = -a(i)
        b(i) = -b(i)
    End If

    Function = Type( a(i), b(i) )

End Function
' ------=< MAIN >=------

Dim As Integer x, y, gcd
Dim As ext_euclid result

Do
    Read x, y
    If x = 0 AndAlso y = 0 Then Exit Do
    result = magic_box(x, y)
    With result
        gcd = .a * x + .b * y
        Print "a * "; Str(x); " + b * "; Str(y);
        Print " = GCD("; Str(x); ", "; Str(y); ") ="; gcd
        If gcd > 1 Then
            Print "No solution, numbers are not coprime"
        Else
            Print "a = "; .a; ", b = ";.b
            Print "The Modular inverse of "; x; " modulo "; y; " = ";
            While .a < 0 : .a += IIf(y > 0, y, -y) : Wend
            Print .a
            'Print "The Modular inverse of "; y; " modulo "; x; " = ";
            'While .b < 0 : .b += IIf(x > 0, x, -x) : Wend
            'Print .b
        End if
    End With
    Print
Loop

Data 42, 2017
Data 40, 1
Data 52, -217
Data -486, 217
Data 40, 2018
Data 0, 0

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


import integers.egcd

def modinv( a, m ) =
    val (g, x, _) = egcd( a, m )

    if g != 1 then error( a + ' and ' + m + ' not coprime' )

    val res = x % m

    if res < 0 then res + m else res

println( modinv(42, 2017) )


package main

import (
	"fmt"
	"math/big"
)

func main() {
	a := big.NewInt(42)
	m := big.NewInt(2017)
	k := new(big.Int).ModInverse(a, m)
	fmt.Println(k)
}


10 ' Modular inverse
20 LET E% = 42
30 LET T% = 2017
40 GOSUB 1000
50 PRINT MODINV%
60 END

990  ' increments e stp (step) times until bal is greater than t
992  ' repeats until bal = 1 (mod = 1) and returns count
994  ' bal will not be greater than t + e
1000 LET D% = 0
1010 IF E% >= T% THEN GOTO 1140
1020  LET BAL% = E%
1025  ' At least one iteration is necessary
1030  LET STP% = ((T% - BAL%) \ E%) + 1
1040  LET BAL% = BAL% + STP% * E%
1050  LET COUNT% = 1 + STP%
1060  LET BAL% = BAL% - T%
1070  WHILE BAL% <> 1
1080   LET STP% = ((T% - BAL%) \ E%) + 1
1090   LET BAL% = BAL% + STP% * E%
1100   LET COUNT% = COUNT% + STP%
1110   LET BAL% = BAL% - T%
1120  WEND
1130  LET D% = COUNT%
1140 LET MODINV% = D%
1150 RETURN


-- Given a and m, return Just x such that ax = 1 mod m.
-- If there is no such x return Nothing.
modInv :: Int -> Int -> Maybe Int
modInv a m
  | 1 == g = Just (mkPos i)
  | otherwise = Nothing
  where
    (i, _, g) = gcdExt a m
    mkPos x
      | x < 0 = x + m
      | otherwise = x

-- Extended Euclidean algorithm.
-- Given non-negative a and b, return x, y and g
-- such that ax + by = g, where g = gcd(a,b).
-- Note that x or y may be negative.
gcdExt :: Int -> Int -> (Int, Int, Int)
gcdExt a 0 = (1, 0, a)
gcdExt a b =
  let (q, r) = a `quotRem` b
      (s, t, g) = gcdExt b r
  in (t, s - q * t, g)

main :: IO ()
main = mapM_ print [2 `modInv` 4, 42 `modInv` 2017]


procedure main(args)
    a := integer(args[1]) | 42
    b := integer(args[2]) | 2017
    write(mul_inv(a,b))
end

procedure mul_inv(a,b)
    if b == 1 then return 1
    (b0 := b, x0 := 0, x1 := 1)
    while a > 1 do {
        q := a/b
        (t := b, b := a%b, a := t)
        (t := x0, x0 := x1-q*x0, x1 := t)
        }
    return if (x1 > 0) then x1 else x1+b0
end


100 PRINT MODINV(42,2017)
120 DEF MODINV(A,B)
130   LET B=ABS(B)
140   IF A<0 THEN LET A=B-MOD(-A,B)
150   LET T=0:LET NT=1:LET R=B:LET NR=MOD(A,B)
160   DO WHILE NR<>0
170     LET Q=INT(R/NR)
180     LET TMP=NT:LET NT=T-Q*NT:LET T=TMP
190     LET TMP=NR:LET NR=R-Q*NR:LET R=TMP
200   LOOP
210   IF R>1 THEN
220     LET MODINV=-1
230   ELSE IF T<0 THEN
240     LET MODINV=T+B
250   ELSE
260     LET MODINV=T
270   END IF
280 END DEF


modInv =: dyad def 'x y&|@^ <: 5 p: y'"0


var modInverse = function(a, b) {
    a %= b;
    for (var x = 1; x < b; x++) {
        if ((a*x)%b == 1) {
            return x;
        }
    }
}


# Integer division:
# If $j is 0, then an error condition is raised;
# otherwise, assuming infinite-precision integer arithmetic,
# if the input and $j are integers, then the result will be an integer.
def idivide($j):
  . as $i
  | ($i % $j) as $mod
  | ($i - $mod) / $j ;

# the multiplicative inverse of . modulo $n
def modInv($n):
  if $n == 1 then 1
  else . as $this
  | { r   : $n,
      t   : 0,
      newR: length, # abs
      newT: 1}
  | until(.newR == 0;
        .newR as $newR
        | (.r | idivide($newR)) as $q
        | {r   : $newR,
           t   : .newT,
           newT: (.t - $q * .newT),
           newR: (.r - $q * $newR) } )

  | if (.r|length) != 1 then "\($this) and \($n) are not co-prime." | error
    else .t
    | if .     < 0 then . + $n
      elif $this < 0 then - .
      else .
      end
    end
  end ;

# Example:
42 | modInv(2017)


// version 1.0.6

import java.math.BigInteger

fun main(args: Array<String>) {
    val a = BigInteger.valueOf(42)
    val m = BigInteger.valueOf(2017)
    println(a.modInverse(m))
}


            NORMAL MODE IS INTEGER
            INTERNAL FUNCTION(AA, BB)
            ENTRY TO MULINV.
            A = AA
            B = BB
            WHENEVER B.L.0, B = -B
            WHENEVER A.L.0, A = B - (-(A-A/B*B))
            T = 0
            NT = 1
            R = B
            NR = A-A/B*B
LOOP        WHENEVER NR.NE.0
                Q = R/NR
                TMP = NT
                NT = T - Q*NT
                T = TMP
                TMP = NR
                NR = R - Q*NR
                R = TMP
                TRANSFER TO LOOP
            END OF CONDITIONAL
            WHENEVER R.G.1, FUNCTION RETURN -1
            WHENEVER T.L.0, T = T+B
            FUNCTION RETURN T
            END OF FUNCTION

            INTERNAL FUNCTION(AA, BB)
            VECTOR VALUES FMT = $I5,2H, ,I5,2H: ,I5*$
            ENTRY TO SHOW.
            PRINT FORMAT FMT, AA, BB, MULINV.(AA, BB)
            END OF FUNCTION

            SHOW.(42,2017)
            SHOW.(40,1)
            SHOW.(52,-217)
            SHOW.(-486,217)
            SHOW.(40,2018)
            END OF PROGRAM


modInv[a_, m_] :=
 Block[{x,k}, x /. FindInstance[a x == 1 + k m, {x, k}, Integers]]


MODULE ModularInverse;
  FROM InOut IMPORT WriteString, WriteInt, WriteLn;

  TYPE Data = RECORD x : INTEGER;
                     y : INTEGER
              END;

  VAR c  : INTEGER;
      ab : ARRAY [1..5] OF Data;

PROCEDURE mi(VAR a, b : INTEGER): INTEGER;
  VAR t, nt, r, nr, q, tmp : INTEGER;

BEGIN
  b := ABS(b);
  IF a < 0 THEN a := b - (-a MOD b) END;
  t := 0; nt := 1; r := b; nr := a MOD b;
  WHILE (nr # 0) DO
    q := r / nr;
    tmp := nt; nt := t - q * nt; t := tmp;
    tmp := nr; nr := r - q * nr; r := tmp;
  END;
  IF (r > 1) THEN RETURN -1 END;
  IF (t < 0) THEN RETURN t + b END;
  RETURN t;
END mi;

BEGIN
  ab[1].x := 42;   ab[1].y := 2017;
  ab[2].x := 40;   ab[2].y := 1;
  ab[3].x := 52;   ab[3].y := -217;
  ab[4].x := -486; ab[4].y := 217;
  ab[5].x := 40;   ab[5].y := 2018;
  WriteLn;
  WriteString("Modular inverse");
  WriteLn;
  FOR c := 1 TO 5 DO
    WriteInt(ab[c].x, 6); WriteString(", ");
    WriteInt(ab[c].y, 6); WriteString(" = ");
    WriteInt(mi(ab[c].x, ab[c].y),6);
    WriteLn;
  END;
END ModularInverse.


(define (modular-multiplicative-inverse a n)
    (if (< n 0)
        (setf n (abs n)))

    (if (< a 0)
        (setf a (- n (% (- 0 a) n))))

    (setf t 0)
    (setf nt 1)
    (setf r n)
    (setf nr (mod a n))

    (while (not (zero? nr))
        (setf q (int (div r nr)))
        (setf tmp nt)
        (setf nt (sub t (mul q nt)))
        (setf t tmp)
        (setf tmp nr)
        (setf nr (sub r (mul q nr)))
        (setf r tmp))

    (if (> r 1)
        (setf retvalue nil))

    (if (< t 0)
        (setf retvalue (add t n))
        (setf retvalue t))
    retvalue)

(println (modular-multiplicative-inverse 42 2017))


proc modInv(a0, b0: int): int =
  var (a, b, x0) = (a0, b0, 0)
  result = 1
  if b == 1: return
  while a > 1:
    result = result - (a div b) * x0
    a = a mod b
    swap a, b
    swap x0, result
  if result < 0: result += b0

echo modInv(42, 2017)


let mul_inv a = function 1 -> 1 | b ->
  let rec aux a b x0 x1 =
    if a <= 1 then x1 else
    if b = 0 then failwith "mul_inv" else
    aux b (a mod b) (x1 - (a / b) * x0) x0
  in
  let x = aux a b 0 1 in
  if x < 0 then x + b else x


// euclid ( a b -- u v r )
//    Return r = gcd(a, b) and (u, v) / r = au + bv

: euclid(a, b)
| q u u1 v v1 |

   b 0 < ifTrue: [ b neg ->b ]
   a 0 < ifTrue: [ b a neg b mod - ->a ]

   1 dup ->u ->v1
   0 dup ->v ->u1

   while(b) [
      b a b /mod ->q ->b ->a
      u1 u u1 q * - ->u1 ->u
      v1 v v1 q * - ->v1 ->v
      ]
   u v a ;

: invmod(a, modulus)
   a modulus euclid 1 == ifFalse: [ drop drop null return ]
   drop dup 0 < ifTrue: [ modulus + ] ;


// increments e step times until bal is greater than t
// repeats until bal = 1 (mod = 1) and returns count
// bal will not be greater than t + e

function modInv(e, t : integer) : integer;
  var
    d : integer;
    bal, count, step : integer;
  begin
    d := 0;
    if e < t then
      begin
        count := 1;
        bal := e;
        repeat
          step := ((t-bal) DIV e)+1;
          bal := bal + step * e;
          count := count + step;
          bal := bal - t;
        until bal = 1;
        d := count;
      end;
    modInv := d;
  end;


use bigint; say 42->bmodinv(2017);
# or
use Math::ModInt qw/mod/;  say mod(42, 2017)->inverse->residue;
# or
use Math::Pari qw/PARI lift/; say lift PARI "Mod(1/42,2017)";
# or
use Math::GMP qw/:constant/; say 42->bmodinv(2017);
# or
use ntheory qw/invmod/; say invmod(42, 2017);


function mul_inv(integer a, n)
    if n<0 then n = -n end if
    if a<0 then a = n - mod(-a,n) end if
    integer t = 0,  nt = 1,
            r = n,  nr = a;
    while nr!=0 do
        integer q = floor(r/nr)
        {t, nt} = {nt, t-q*nt}
        {r, nr} = {nr, r-q*nr}
    end while
    if r>1 then return "a is not invertible" end if
    if t<0 then t += n end if
    return t
end function

?mul_inv(42,2017)
?mul_inv(40, 1)
?mul_inv(52, -217)  /* Pari semantics for negative modulus */
?mul_inv(-486, 217)
?mul_inv(40, 2018)


(de modinv (A B)
   (let (B0 B  X0 0  X1 1  Q 0  T1 0)
      (while (< 1 A)
         (setq
            Q (/ A B)
            T1 B
            B (% A B)
            A T1
            T1 X0
            X0 (- X1 (* Q X0))
            X1 T1 ) )
      (if (lt0 X1) (+ X1 B0) X1) ) )

(println
   (modinv 42 2017) )

(bye)


function invmod($a,$n){
        if ([int]$n -lt 0) {$n = -$n}
        if ([int]$a -lt 0) {$a = $n - ((-$a) % $n)}

	$t = 0
	$nt = 1
	$r = $n
	$nr = $a % $n
	while ($nr -ne 0) {
		$q = [Math]::truncate($r/$nr)
		$tmp = $nt
		$nt = $t - $q*$nt
		$t = $tmp
		$tmp = $nr
		$nr = $r - $q*$nr
		$r = $tmp
	}
	if ($r -gt 1) {return -1}
	if ($t -lt 0) {$t += $n}
	return $t
}

invmod 42 2017


egcd(_, 0, 1, 0) :- !.
egcd(A, B, X, Y) :-
    divmod(A, B, Q, R),
    egcd(B, R, S, X),
    Y is S - Q*X.

modinv(A, B, N) :-
    egcd(A, B, X, Y),
    A*X + B*Y =:= 1,
    N is X mod B.


EnableExplicit
Declare main()
Declare.i mi(a.i, b.i)

If OpenConsole("MODULAR-INVERSE")
  main() : Input() : End
EndIf

Macro ModularInverse(a, b)
  PrintN(~"\tMODULAR-INVERSE(" + RSet(Str(a),5) + "," +
         RSet(Str(b),5)+") = " +
         RSet(Str(mi(a, b)),5))
EndMacro

Procedure main()
  ModularInverse(42, 2017)  ; = 1969
  ModularInverse(40, 1)     ; = 0
  ModularInverse(52, -217)  ; = 96
  ModularInverse(-486, 217) ; = 121
  ModularInverse(40, 2018)  ; = -1
EndProcedure

Procedure.i mi(a.i, b.i)
  Define x.i = 1,
         y.i = Int(Abs(b)),
         r.i = 0
  If y = 1 : ProcedureReturn 0 : EndIf
  While x < y
    r = (a * x) % b
    If r = 1 Or (y + r) = 1
      Break
    EndIf
    x + 1
  Wend
  If x > y - 1 : x = -1 : EndIf
  ProcedureReturn x
EndProcedure


>>> def extended_gcd(aa, bb):
    lastremainder, remainder = abs(aa), abs(bb)
    x, lastx, y, lasty = 0, 1, 1, 0
    while remainder:
        lastremainder, (quotient, remainder) = remainder, divmod(lastremainder, remainder)
        x, lastx = lastx - quotient*x, x
        y, lasty = lasty - quotient*y, y
    return lastremainder, lastx * (-1 if aa < 0 else 1), lasty * (-1 if bb < 0 else 1)

>>> def modinv(a, m):
	g, x, y = extended_gcd(a, m)
	if g != 1:
		raise ValueError
	return x % m

>>> modinv(42, 2017)
1969
>>>


  [ dup 1 != if
      [ tuck 1 0
        [ swap temp put
          temp put
          over 1 > while
          tuck /mod swap
          temp take tuck *
          temp take swap -
          again ]
        2drop
        temp release
        temp take
        dup 0 < if
          [ over + ] ]
    nip ]                 is modinv ( n n --> n )

  42 2017 modinv echo


(require math)
(modular-inverse 42 2017)


sub inverse($n, :$modulo) {
    my ($c, $d, $uc, $vc, $ud, $vd) = ($n % $modulo, $modulo, 1, 0, 0, 1);
    my $q;
    while $c != 0 {
        ($q, $c, $d) = ($d div $c, $d % $c, $c);
        ($uc, $vc, $ud, $vd) = ($ud - $q*$uc, $vd - $q*$vc, $uc, $vc);
    }
    return $ud % $modulo;
}

say inverse 42, :modulo(2017)


/*REXX program calculates and displays the  modular inverse  of an integer  X  modulo Y.*/
parse arg x y .                                  /*obtain two integers from the C.L.    */
if x=='' | x==","  then x=   42                  /*Not specified?  Then use the default.*/
if y=='' | y==","  then y= 2017                  /* "      "         "   "   "     "    */
say  'modular inverse of '      x       " by "       y        ' ───► '         modInv(x,y)
exit                                             /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
modInv: parse arg a,b 1 ob;     z= 0             /*B & OB are obtained from the 2nd arg.*/
        $= 1                                     /*initialize modular inverse to unity. */
        if b\=1  then do  while a>1
                      parse value   a/b  a//b  b  z       with      q  b  a  t
                      z= $  -  q * z
                      $= trunc(t)
                      end   /*while*/

        if $<0  then $= $ + ob                   /*Negative?  Then add the original  B. */
        return $


see "42 %! 2017 = " + multInv(42, 2017) + nl

func multInv a,b
     b0 = b
     x0 = 0
     multInv = 1
     if b = 1 return 0 ok
     while a > 1
           q = floor(a / b)
           t = b
           b = a % b
           a = t
           t = x0
           x0 = multInv - q * x0
           multInv = t
     end
     if multInv < 0 multInv = multInv + b0 ok
     return multInv


#based on pseudo code from http://en.wikipedia.org/wiki/Extended_Euclidean_algorithm#Iterative_method_2 and from translating the python implementation.
def extended_gcd(a, b)
  last_remainder, remainder = a.abs, b.abs
  x, last_x, y, last_y = 0, 1, 1, 0
  while remainder != 0
    last_remainder, (quotient, remainder) = remainder, last_remainder.divmod(remainder)
    x, last_x = last_x - quotient*x, x
    y, last_y = last_y - quotient*y, y
  end

  return last_remainder, last_x * (a < 0 ? -1 : 1)
end

def invmod(e, et)
  g, x = extended_gcd(e, et)
  if g != 1
    raise 'The maths are broken!'
  end
  x % et
end


print multInv(42, 2017)
end

function multInv(a,b)
	b0	= b
	multInv	= 1
	if b = 1 then goto [endFun]
	while a > 1
		q	= a / b
		t	= b
		b	= a mod b
		a	= t
		t	= x0
		x0	= multInv - q * x0
		multInv	= int(t)
	wend
	if multInv < 0 then multInv = multInv + b0
[endFun]
end function


fn mod_inv(a: isize, module: isize) -> isize {
  let mut mn = (module, a);
  let mut xy = (0, 1);

  while mn.1 != 0 {
    xy = (xy.1, xy.0 - (mn.0 / mn.1) * xy.1);
    mn = (mn.1, mn.0 % mn.1);
  }

  while xy.0 < 0 {
    xy.0 += module;
  }
  xy.0
}

fn main() {
  println!("{}", mod_inv(42, 2017))
}


def gcdExt(u: Int, v: Int): (Int, Int, Int) = {
  @tailrec
  def aux(a: Int, b: Int, x: Int, y: Int, x1: Int, x2: Int, y1: Int, y2: Int): (Int, Int, Int) = {
    if(b == 0) (x, y, a) else {
      val (q, r) = (a / b, a % b)
      aux(b, r, x2 - q * x1, y2 - q * y1, x, x1, y, y1)
    }
  }
  aux(u, v, 1, 0, 0, 1, 1, 0)
}

def modInv(a: Int, m: Int): Option[Int] = {
  val (i, j, g) = gcdExt(a, m)
  if (g == 1) Option(if (i < 0) i + m else i) else Option.empty
}


const func bigInteger: modInverse (in var bigInteger: a,
    in var bigInteger: b) is func
  result
    var bigInteger: modularInverse is 0_;
  local
    var bigInteger: b_bak is 0_;
    var bigInteger: x is 0_;
    var bigInteger: y is 1_;
    var bigInteger: lastx is 1_;
    var bigInteger: lasty is 0_;
    var bigInteger: temp is 0_;
    var bigInteger: quotient is 0_;
  begin
    if b < 0_ then
      raise RANGE_ERROR;
    end if;
    if a < 0_ and b <> 0_ then
      a := a mod b;
    end if;
    b_bak := b;
    while b <> 0_ do
      temp := b;
      quotient := a div b;
      b := a rem b;
      a := temp;

      temp := x;
      x := lastx - quotient * x;
      lastx := temp;

      temp := y;
      y := lasty - quotient * y;
      lasty := temp;
    end while;
    if a = 1_ then
      modularInverse := lastx;
      if modularInverse < 0_ then
        modularInverse +:= b_bak;
      end if;
    else
      raise RANGE_ERROR;
    end if;
  end func;


extension BinaryInteger {
  @inlinable
  public func modInv(_ mod: Self) -> Self {
    var (m, n) = (mod, self)
    var (x, y) = (Self(0), Self(1))

    while n != 0 {
      (x, y) = (y, x - (m / n) * y)
      (m, n) = (n, m % n)
    }

    while x < 0 {
      x += mod
    }

    return x
  }
}

print(42.modInv(2017))


proc gcdExt {a b} {
    if {$b == 0} {
	return [list 1 0 $a]
    }
    set q [expr {$a / $b}]
    set r [expr {$a % $b}]
    lassign [gcdExt $b $r] s t g
    return [list $t [expr {$s - $q*$t}] $g]
}
proc modInv {a m} {
    lassign [gcdExt $a $m] i -> g
    if {$g != 1} {
	return -code error "no inverse exists of $a %! $m"
    }
    while {$i < 0} {incr i $m}
    return $i
}


    PRINT "Modular inverse."
    PRINT "What is the modulus?"
    INPUT M
    PRINT "What number is to be inverted?"
    INPUT X
    PRINT "Solution is:"
10  LET A = A + 1
    GOTO 20
15  IF B = 1 THEN PRINT A
    IF B = 1 THEN END
    IF A = M-1 THEN PRINT "nonexistent"
    IF A = M-1 THEN END
    GOTO 10
20  LET B = A*X
30  IF B < M THEN GOTO 15
    LET B = B - M
    GOTO 30


;WITH Iterate(N,A,B,X0,X1)
	AS (
		SELECT
			1
			,CASE WHEN @a < 0 THEN @b-(-@a % @b) ELSE @a END
			,CASE WHEN @b < 0 THEN -@b ELSE @b END
			,0
			,1
		UNION ALL
		SELECT
			N+1
			,B
			,A%B
			,X1-((A/B)*X0)
			,X0
		FROM Iterate
		WHERE A != 1 AND B != 0
	),
	ModularInverse(Result)
	AS (
		SELECT
			-1
			FROM Iterate
			WHERE A != 1 AND B = 0
		UNION ALL
		SELECT
			TOP(1)
			CASE WHEN X1 < 0 THEN X1+@b ELSE X1 END AS Result
			FROM Iterate
			WHERE (SELECT COUNT(*) FROM Iterate WHERE A != 1 AND B = 0) = 0
			ORDER BY N DESC
	)
	SELECT *
	FROM ModularInverse


// Modular inverse

function modInv(e: number, t: number): number {
  var d = 0;
  if (e < t) {
    var count = 1;
    var bal = e;
    do {
      var step = Math.floor((t - bal) / e) + 1;
      bal += step * e;
      count += step;
      bal -= t;
    } while (bal != 1);
    d = count;
  }
  return d;
}

console.log(`${modInv(42, 2017)}`); // 1969


Print FUNC(_MulInv(42, 2017))
End

_MulInv Param(2)
  Local(5)

  [email protected] = [email protected]
  [email protected] = 0
  [email protected] = 1

  If [email protected] = 1 Then Return

  Do While [email protected] > 1
    [email protected] = [email protected] / [email protected]
    [email protected] = [email protected]
    [email protected] = [email protected] % [email protected]
    [email protected] = [email protected]

    [email protected] = [email protected]
    [email protected] = [email protected] - [email protected] * [email protected]
    [email protected] = [email protected]
  Loop

  If [email protected] < 0 Then [email protected] = [email protected] + [email protected]
Return ([email protected])


function invmod {
  typeset -i a=$1 n=$2
  if (( n < 0 )); then (( n = -n )); fi
  if (( a < 0 )); then (( a = n - (-a) % n )); fi

  typeset -i t=0 nt=1 r=n nr q tmp
  (( nr = a % n ))
  while ((  nr )); do
    (( q = r/nr ))
    (( tmp = nt ))
    (( nt = t - q*nt ))
    (( t = tmp ))
    (( tmp = nr ))
    (( nr = r - q*nr ))
    (( r = tmp ))
  done
  if (( r > 1 )); then
    return 1
  fi
  while (( t < 0 )); do (( t += n )); done
  printf '%s\n' "$t"
}

invmod 42 2017


Private Function mul_inv(a As Long, n As Long) As Variant
    If n < 0 Then n = -n
    If a < 0 Then a = n - ((-a) Mod n)
    Dim t As Long: t = 0
    Dim nt As Long: nt = 1
    Dim r As Long: r = n
    Dim nr As Long: nr = a
    Dim q As Long
    Do While nr <> 0
        q = r \ nr
        tmp = t
        t = nt
        nt = tmp - q * nt
        tmp = r
        r = nr
        nr = tmp - q * nr
    Loop
    If r > 1 Then
        mul_inv = "a is not invertible"
    Else
        If t < 0 Then t = t + n
        mul_inv = t
    End If
End Function
Public Sub mi()
    Debug.Print mul_inv(42, 2017)
    Debug.Print mul_inv(40, 1)
    Debug.Print mul_inv(52, -217) '/* Pari semantics for negative modulus */
    Debug.Print mul_inv(-486, 217)
    Debug.Print mul_inv(40, 2018)
End Sub


import "/big" for BigInt

var a = BigInt.new(42)
var b = BigInt.new(2017)
System.print(a.modInv(b))


code IntOut=11, Text=12;
int  X;
def  A=42, M=2017;
[for X:= 2 to M-1 do
    if rem(A*X/M) = 1 then [IntOut(0, X);  exit];
Text(0, "Does not exist");
]


fcn gcdExt(a,b){
   if(b==0) return(1,0,a);
   q,r:=a.divr(b); s,t,g:=gcdExt(b,r); return(t,s-q*t,g);
}
fcn modInv(a,m){i,_,g:=gcdExt(a,m); if(g==1) {if(i<0)i+m} else Void}


	cpu	8086
	bits	16
	;;;	I/O ports
KBB:	equ	61h	; Keyboard controller port B (also controls speaker)
PITC2:	equ	42h	; Programmable Interrupt Timer, channel 2 (frequency)
PITCTL:	equ	43h	; PIT control port.
	;;;	Control bits
SPKR:	equ	3	; Lower two bits of KBB determine speaker on/off
CTR:	equ	6	; Counter select offset in PIT control byte
CBITS:	equ	4	; Size select offset in PIT control byte
B16:	equ	3	; 16-bit mode for the PIT counter
MODE:	equ	1	; Offset of mode in PIT control byte
SQWV:	equ	3	; Square wave mode
	;;;	Software interrupts
CLOCK:	equ	1Ah	; BIOS clock function interrupt
DOS:	equ	21h	; MS-DOS syscall interrupt
	;;;	MS-DOS syscalls
read:	equ	3Fh	; Read from file
section	.text
	org	100h
	;;;	Set up the PIT to generate a 'C' note
	cli
	mov	al,(2<<CTR)|(B16<<CBITS)|(SQWV<<MODE)
	out	PITCTL,al
	mov	ax,2280		; Divisor of main oscillator frequency
	out	PITC2,al	; Output low byte first,
	xchg	al,ah
	out	PITC2,al	; Then high byte.
	sti
	;;;	Read from stdin and sound as morse
input:	mov	ah,read		; Read
	xor	bx,bx		; from STDIN
	mov	cx,buf.size	; into the buffer
	mov	dx,buf
	int	DOS
	jc	stop		; Carry set = error, stop
	test	ax,ax		; Did we get any characters?
	jnz	go		; If not, we're done, so stop
stop:	ret
go:	mov	cx,ax		; Loop counter = how many characters we have
	mov	si,buf		; Start at buffer size
dochar:	lodsb			; Get current character
	cmp	al,26		; End of file?
	je	stop		; Then stop
	push	cx		; Save pointer and counter
	push	si
	call	char		; Sound out this character
	pop	si		; Restore pointer and counter
	pop	cx
	loop	dochar		; If more characters, do the next one
	jmp	input		; Afterwards, try to get more input
	;;;	Sound ASCII character in AL
char:	and	al,127		; 7-bit ASCII
	sub	al,32		; Word separator? (<=32)
	ja	.snd		; If not, look up in table
	mov	bx,4		; Otherwise, 'sound' a word space
	jmp	delay		; (4 more ticks to form 7-tick delay)
.snd:	mov	bx,morse	; Find offset in morse pulse table
	xlatb
	test	al,al		; If it is zero, we want to ignore it
	jz	.out
	xor	ah,ah		; Otherwise, find its address
	mov	bx,ax
	lea	si,[bx+morse.P]	; and store it in SI.
	xor	bh,bh		; BX = BL in the following code
.byte:	lodsb			; Get pulse byte
	mov	cx,4		; Four pulses per byte
.pulse:	mov	bl,3		; Load low pulse in BL
	and	bl,al
	test	bl,bl		; If it is zero,
	jz	.out		; We're done
	mov	bp,ax		; Otherwise, keep AX
	call	pulse		; Sound the pulse
	mov	ax,bp		; Restore AX
	shr	al,1		; Next pulse
	shr 	al,1
	loop	.pulse
	jmp	.byte		; If no zero pulse seen yet, next byte
.out:	mov	bl,2		; 2 ticks more delay to form inter-char space
	jmp	delay
	;;;	Sound morse code pulse w/delay
pulse:	cli			; Turn off interrupts
	in	al,KBB		; Read current configuration
	or	al,SPKR		; Turn speaker on
	out	KBB,al		; Write configuration back
	sti			; Turn interrupts back on
	call	delay		; Delay for BX ticks
	cli			; Turn off interrupts
	in	al,KBB		; Read current configuration
	and	al,~SPKR	; Turn speaker off
	out	KBB,al		; Write configuration back
	sti			; Turn interrupts back on
	mov	bx,1		; Intra-character delay = 1 tick
	;;;	Delay for BX ticks
delay:	push	bx		; Keep the registers we alter
	push	cx
	push	dx
	xor	ah,ah		; Clock function 0 = get ticks
	int	CLOCK		; Get current ticks (in CX:DX)
	add	bx,dx		; BX = time for which to wait
.wait:	int	CLOCK		; Wait for that time to occur
	cmp	dx,bx		; Are we there yet?
	jbe	.wait		; If not, try again
	pop	dx		; Restore the registers
	pop	cx
	pop 	bx
	ret
section	.data
morse:	;;;	Printable ASCII to pulse mapping (32-122)
	db	.n_-.P,		.excl-.P,	.dquot-.P,	.n_-.P	; !"#
	db	.dolar-.P,	.n_-.P,		.amp-.P,	.quot-.P;$%&'
	db	.open-.P,	.close-.P,	.n_-.P,		.plus-.P;()*+
	db	.comma-.P,	.minus-.P,	.dot-.P,	.slsh-.P;,-./
	db	.n0-.P,		.n1-.P,		.n2-.P,		.n3-.P	;0123
	db	.n4-.P,		.n5-.P,		.n6-.P,		.n7-.P	;4567
	db	.n8-.P,		.n9-.P,		.colon-.P,	.semi-.P;89:;
	db	.n_-.P,		.eq-.P,		.n_-.P,		.qm-.P 	;<=>?
	db	.at-.P,		.a-.P,		.b-.P,		.c-.P	;@ABC
	db	.d-.P,		.e-.P,		.f-.P,		.g-.P	;DEFG
	db	.h-.P,		.i-.P,		.j-.P,		.k-.P	;HIJK
	db	.l-.P,		.m-.P,		.n-.P,		.o-.P	;LMNO
	db	.p-.P,		.q-.P,		.r-.P,		.s-.P	;PQRS
	db	.t-.P,		.u-.P,		.v-.P,		.w-.P	;TUVW
	db	.x-.P,		.y-.P,		.z-.P,		.n_-.P	;XYZ[
	db	.n_-.P,		.n_-.P,		.n_-.P,		.uscr-.P;\]^_
	db	.n_-.P,		.a-.P,		.b-.P,		.c-.P	;`abc
	db	.d-.P,		.e-.P,		.f-.P,		.g-.P	;defg
	db	.h-.P,		.i-.P,		.j-.P,		.k-.P	;hijk
	db	.l-.P,		.m-.P,		.n-.P,		.o-.P	;lmno
	db	.p-.P,		.q-.P,		.r-.P,		.s-.P	;pqrs
	db	.t-.P,		.u-.P,		.v-.P,		.w-.P	;tuvw
	db	.x-.P,		.y-.P,		.z-.P,		.n_-.P	;xyz{
	db	.n_-.P,		.n_-.P,		.n_-.P,		.n_-.P	;|}~
.P:	;;;	Morse pulses are stored four to a byte, lowest bits first
.n_:	db	0	; To ignore undefined characters
.a:	db	0Dh
.b:	db	57h,0
.c:	db	77h,0
.d:	db	17h
.e:	db	1h
.f:	db	75h,0
.g:	db	1Fh
.h:	db	55h,0
.i:	db	5h
.j:	db	0FDh,0
.k:	db	37h
.l:	db	5Dh,0
.m:	db	0Fh
.n:	db	7h
.o:	db	3Fh
.p:	db	7Dh,0
.q:	db	0DFh,0
.r:	db	1Dh
.s:	db	15h
.t:	db	3h
.u:	db	35h
.v:	db	0D5h,0
.w:	db	3Dh
.x:	db	0D7h,0
.y:	db	0F7h,0
.z:	db	5Fh,0
.n0:	db	0FFh,3
.n1:	db	0FDh,3
.n2:	db	0F5h,3
.n3:	db	0D5h,3
.n4:	db	55h,3
.n5:	db	55h,1
.n6:	db	57h,1
.n7:	db	5Fh,1
.n8:	db	7Fh,1
.n9:	db	0FFh,1
.dot:	db	0DDh,0Dh
.comma:	db	5Fh,0Fh
.qm:	db	0F5h,5
.quot:	db	0FDh,7
.excl:	db	77h,0Fh
.slsh:	db	0D7h,1
.open:	db	0F7h,1
.close:	db	0F7h,0Dh
.amp:	db	5Dh,1
.colon:	db	7Fh,5
.semi:	db	77h,7
.eq:	db	57h,3
.plus:	db	0DDh,1
.minus:	db	57h,0Dh
.uscr:	db	0F5h,0Dh
.dquot:	db	5Dh,7
.dolar:	db	0D5h,35h
.at:	db	7Dh,7
section	.bss
buf:	resb	1024		; 1K buffer
.size:	equ	$-buf


REPORT morse_code.
TYPES: BEGIN OF y_morse_code,
         letter TYPE string,
         code   TYPE string,
       END OF y_morse_code,
       ty_morse_code TYPE STANDARD TABLE OF y_morse_code WITH EMPTY KEY.

cl_demo_output=>new(
          )->begin_section( |Morse Code|
          )->write( REDUCE stringtab( LET words = VALUE stringtab( ( |sos|                 )
                                                                   ( |   Hello     World!| )
                                                                   ( |Rosetta Code|        ) )
                                          morse_code = VALUE ty_morse_code( ( letter = 'A'   code = '.-     ' )
                                                                            ( letter = 'B'   code = '-...   ' )
                                                                            ( letter = 'C'   code = '-.-.   ' )
                                                                            ( letter = 'D'   code = '-..    ' )
                                                                            ( letter = 'E'   code = '.      ' )
                                                                            ( letter = 'F'   code = '..-.   ' )
                                                                            ( letter = 'G'   code = '--.    ' )
                                                                            ( letter = 'H'   code = '....   ' )
                                                                            ( letter = 'I'   code = '..     ' )
                                                                            ( letter = 'J'   code = '.---   ' )
                                                                            ( letter = 'K'   code = '-.-    ' )
                                                                            ( letter = 'L'   code = '.-..   ' )
                                                                            ( letter = 'M'   code = '--     ' )
                                                                            ( letter = 'N'   code = '-.     ' )
                                                                            ( letter = 'O'   code = '---    ' )
                                                                            ( letter = 'P'   code = '.--.   ' )
                                                                            ( letter = 'Q'   code = '--.-   ' )
                                                                            ( letter = 'R'   code = '.-.    ' )
                                                                            ( letter = 'S'   code = '...    ' )
                                                                            ( letter = 'T'   code = '-      ' )
                                                                            ( letter = 'U'   code = '..-    ' )
                                                                            ( letter = 'V'   code = '...-   ' )
                                                                            ( letter = 'W'   code = '.-   - ' )
                                                                            ( letter = 'X'   code = '-..-   ' )
                                                                            ( letter = 'Y'   code = '-.--   ' )
                                                                            ( letter = 'Z'   code = '--..   ' )
                                                                            ( letter = '0'   code = '-----  ' )
                                                                            ( letter = '1'   code = '.----  ' )
                                                                            ( letter = '2'   code = '..---  ' )
                                                                            ( letter = '3'   code = '...--  ' )
                                                                            ( letter = '4'   code = '....-  ' )
                                                                            ( letter = '5'   code = '.....  ' )
                                                                            ( letter = '6'   code = '-....  ' )
                                                                            ( letter = '7'   code = '--...  ' )
                                                                            ( letter = '8'   code = '---..  ' )
                                                                            ( letter = '9'   code = '----.  ' )
                                                                            ( letter = ''''  code = '.----. ' )
                                                                            ( letter = ':'   code = '---... ' )
                                                                            ( letter = ','   code = '--..-- ' )
                                                                            ( letter = '-'   code = '-....- ' )
                                                                            ( letter = '('   code = '-.--.- ' )
                                                                            ( letter = '.'   code = '.-.-.- ' )
                                                                            ( letter = '?'   code = '..--.. ' )
                                                                            ( letter = ';'   code = '-.-.-. ' )
                                                                            ( letter = '/'   code = '-..-.  ' )
                                                                            ( letter = '_'   code = '..--.- ' )
                                                                            ( letter = ')'   code = '---..  ' )
                                                                            ( letter = '='   code = '-...-  ' )
                                                                            ( letter = '@'   code = '.--.-. ' )
                                                                            ( letter = '\'   code = '.-..-. ' )
                                                                            ( letter = '+'   code = '.-.-.  ' )
                                                                            ( letter = ' '   code = '/'       ) )
                                      IN INIT word_coded_tab TYPE stringtab
                                          FOR word IN words
                                         NEXT word_coded_tab = VALUE #( BASE word_coded_tab ( REDUCE string( INIT word_coded TYPE string
                                                                                FOR index = 1 UNTIL index > strlen( word )
                                                                                LET _morse_code = VALUE #( morse_code[ letter = COND #( WHEN index = 1 THEN to_upper( word(index) )
                                                                                ELSE LET prev = index - 1 IN to_upper( word+prev(1) ) ) ]-code OPTIONAL )
                                                                                IN NEXT word_coded = |{ word_coded } { _morse_code }| ) ) ) )
          )->display( ).


DEFINE PTR="CARD"
DEFINE COUNT="$60"

PTR ARRAY code(COUNT)
BYTE
  PALNTSC=$D014,
  dotDuration,dashDuration,
  intraGapDuration,letterGapDuration,wordGapDuration

PROC Init()
  Zero(code,COUNT)
  code('!)="-.-.--"  code('")=".-..-."
  code('$)="...-..-" code('&)=".-..."
  code('')=".----."  code('()="-.--.-"
  code('))="---.."   code('+)=".-.-."
  code(',)="--..--"  code('-)="-....-"
  code('.)=".-.-.-"  code('/)="-..-."
  code('0)="-----"   code('1)=".----"
  code('2)="..---"   code('3)="...--"
  code('4)="....-"   code('5)="....."
  code('6)="-...."   code('7)="--..."
  code('8)="---.."   code('9)="----."
  code(':)="---..."  code(';)="-.-.-."
  code('=)="-...-"   code('?)="..--.."
  code('@)=".--.-."  code('A)=".-"
  code('B)="-..."    code('C)="-.-."
  code('D)="-.."     code('E)="."
  code('F)="..-."    code('G)="--."
  code('H)="...."    code('I)=".."
  code('J)=".---"    code('K)="-.-"
  code('L)=".-.."    code('M)="--"
  code('N)="-."      code('O)="---"
  code('P)=".--."    code('Q)="--.-"
  code('R)=".-."     code('S)="..."
  code('T)="-"       code('U)="..-"
  code('V)="...-"    code('W)=".--"
  code('X)="-..-"    code('Y)="-.--"
  code('Z)="--.."    code('\)=".-..-."
  code('_)="..--.-"

  IF PALNTSC=15 THEN
    dotDuration=6
  ELSE
    dotDuration=5
  FI
  dashDuration=2*dotDuration
  intraGapDuration=dotDuration
  letterGapDuration=3*intraGapDuration
  wordGapDuration=7*intraGapDuration
RETURN

PROC Wait(BYTE frames)
  BYTE RTCLOK=$14
  frames==+RTCLOK
  WHILE frames#RTCLOK DO OD
RETURN

PROC ProcessSound(CHAR ARRAY s BYTE last)
  BYTE i

  FOR i=1 TO s(0)
  DO
    Sound(0,30,10,10)
    IF s(i)='. THEN
      Wait(dotDuration)
    ELSE
      Wait(dashDuration)
    FI
    Sound(0,0,0,0)

    IF i<s(0) THEN
      Wait(intraGapDuration)
    FI
  OD
RETURN

PROC Process(CHAR ARRAY a)
  CHAR ARRAY seq,subs
  BYTE i,first,afterSpace
  CHAR c

  PrintE(a)
  first=1
  afterSpace=0
  FOR i=1 TO a(0)
  DO
    c=a(i)
    IF c>='a AND c<='z THEN
      c=c-'a+'A
    ELSEIF c>=COUNT THEN
      c=0
    FI
    seq=code(c)
    IF seq#0 THEN
      IF first=1 THEN
        first=0
      ELSE
        Put(' )
        IF afterSpace=0 THEN
          Wait(letterGapDuration)
        FI
      FI
      subs=code(c)
      Print(subs)
      ProcessSound(subs)
      afterSpace=0
    ELSEIF c='  THEN
      Print("  ")
      Wait(wordGapDuration)
      afterSpace=1
    ELSE
      afterSpace=0
    FI
  OD
  PutE() PutE()
  Wait(wordGapDuration)
RETURN

PROC Main()
  Init()
  Process("SOS")
  Process("Atari Action!")
  Process("www.rosettacode.org")
RETURN


use AppleScript version "2.4" -- OS X 10.10 (Yosemite) or later
use framework "Foundation"
use framework "AppKit"

on morseCode(msg)
    script morse
        -- Unit duration in seconds and sounds used.
        property units : 0.075
        property morseSound : current application's class "NSSound"'s soundNamed:("Glass")
        property unknownCharacterSound : current application's class "NSSound"'s soundNamed:("Frog")
        -- Unicode IDs of in-range but uncatered-for punctuation characters.
        property unrecognisedPunctuation : {35, 37, 42, 60, 62, 91, 92, 93, 94}
        -- Dits and dahs for recognised characters, in units.
        property letters : {{1, 3}, {3, 1, 1, 1}, {3, 1, 3, 1}, {3, 1, 1}, {1}, {1, 1, 3, 1}, {3, 3, 1}, {1, 1, 1, 1}, {1, 1}, ¬
            {1, 3, 3, 3}, {3, 1, 3}, {1, 3, 1, 1}, {3, 3}, {3, 1}, {3, 3, 3}, {1, 3, 3, 1}, {3, 3, 1, 3}, {1, 3, 1}, {1, 1, 1}, ¬
            {3}, {1, 1, 3}, {1, 1, 1, 3}, {1, 3, 3}, {3, 1, 1, 3}, {3, 1, 3, 3}, {3, 3, 1, 1}}
        property underscore : {1, 1, 3, 3, 1, 3}
        property digitsAndPunctuation : {{3, 3, 3, 3, 3}, {1, 3, 3, 3, 3}, {1, 1, 3, 3, 3}, {1, 1, 1, 3, 3}, ¬
            {1, 1, 1, 1, 3}, {1, 1, 1, 1, 1}, {3, 1, 1, 1, 1}, {3, 3, 1, 1, 1}, {3, 3, 3, 1, 1}, {3, 3, 3, 3, 1}, ¬
            {3, 3, 3, 1, 1, 1}, {3, 1, 3, 1, 3, 1}, missing value, {3, 1, 1, 1, 3}, missing value, ¬
            {1, 1, 3, 3, 1, 1}, {1, 3, 3, 1, 3, 1}}
        property |punctuation| : {{3, 1, 3, 1, 3, 3}, {1, 3, 1, 1, 3, 1}, missing value, {1, 1, 1, 3, 1, 1, 3}, missing value, ¬
            {1, 3, 1, 1, 1}, {1, 3, 3, 3, 3, 1}, {3, 1, 3, 3, 1}, {3, 1, 3, 3, 1, 3}, missing value, ¬
            {1, 3, 1, 3, 1}, {3, 3, 1, 1, 3, 3}, {3, 1, 1, 1, 1, 3}, {1, 3, 1, 3, 1, 3}, {3, 1, 1, 3, 1}}
        -- Unicode IDs of the message's characters.
        property UnicodeIDs : (id of msg) as list

        on sendCharacter(ditsAndDahs)
            repeat with ditOrDah in ditsAndDahs
                tell morseSound to play()
                delay (ditOrDah * units)
                tell morseSound to stop()
                delay (1 * units)
            end repeat
            delay (2 * units) -- Previous 1 unit + 2 units = 3 units between characters.
        end sendCharacter

        on sendMessage()
            -- Play an extremely short sound to ensure the sound system's awake for the first morse beep.
            tell morse to sendCharacter({0})
            -- Output the message.
            repeat with i from 1 to (count UnicodeIDs)
                set thisID to item i of my UnicodeIDs
                if ((thisID > 122) or (thisID < 32) or (thisID is in unrecognisedPunctuation)) then
                    -- Character not catered for. Play alternative sound.
                    tell unknownCharacterSound to play()
                    delay (3 * units)
                    tell unknownCharacterSound to stop()
                    delay (3 * units)
                else if ((thisID > 64) and ((thisID < 91) or (thisID > 96))) then -- English letter.
                    sendCharacter(item (thisID mod 32) of my letters)
                else if (thisID is 95) then -- Underscore.
                    sendCharacter(underscore)
                else if (thisID > 47) then -- Digit, colon, semicolon, equals, or question mark.
                    sendCharacter(item (thisID - 47) of my digitsAndPunctuation)
                else if (thisID > 32) then -- Other recognised punctuation.
                    sendCharacter(item (thisID - 32) of my |punctuation|)
                else -- Space.
                    delay (4 * units) -- Previous 3 units + 4 units = 7 units between "words".
                end if
            end repeat
        end sendMessage
    end script

    tell morse to sendMessage()
end morseCode

-- Test code:
morseCode("Coded in AppleScrip†.")


TestString := "Hello World! abcdefg @\;"			;Create a string to be sent with multiple caps and some punctuation
MorseBeep(teststring)					;Beeps our string after conversion
return										;End Auto-Execute Section

MorseBeep(passedString)
{
	StringLower, passedString, passedString			;Convert to lowercase for simpler checking
	Loop, Parse, passedString					;This loop stores each character in A_loopField one by one using the more compact form of "if else", by var := x>y ? val1 : val2 which stores val1 in var if x > y, otherwise it stores val2, this can be used together to make a single line of if else
		morse .= A_LoopField = " " ?  "     " : A_LoopField = "a" ? ".- " : A_LoopField = "b" ? "-... " : A_LoopField = "c" ? "-.-. " : A_LoopField = "d" ? "-.. " : A_LoopField = "e" ? ". " : A_LoopField = "f" ? "..-. " : A_LoopField = "g" ? "--. " : A_LoopField = "h" ? ".... " : A_LoopField = "i" ? ".. " : A_LoopField = "j" ? ".--- " : A_LoopField = "k" ? "-.- " : A_LoopField = "l" ? ".-.. " : A_LoopField = "m" ? "-- " : A_LoopField = "n" ? "-. " : A_LoopField = "o" ? "--- " : A_LoopField = "p" ? ".--. " : A_LoopField = "q" ? "--.- " : A_LoopField = "r" ? ".-. " : A_LoopField = "s" ? "... " : A_LoopField = "t" ? "- " : A_LoopField = "u" ? "..- " : A_LoopField = "v" ? "...- " : A_LoopField = "w" ? ".-- " : A_LoopField = "x" ? "-..- " : A_LoopField = "y" ? "-.-- " : A_LoopField = "z" ? "--.. " : A_LoopField = "!" ? "---. " : A_LoopField = "\" ? ".-..-. " : A_LoopField = "$" ? "...-..- " : A_LoopField = "'" ? ".----. " : A_LoopField = "(" ? "-.--. " : A_LoopField = ")" ? "-.--.- " : A_LoopField = "+" ? ".-.-. " : A_LoopField = "," ? "--..-- " : A_LoopField = "-" ? "-....- " : A_LoopField = "." ? ".-.-.- " : A_LoopField = "/" ? "-..-. " : A_LoopField = "0" ? "----- " : A_LoopField = "1" ? ".---- " : A_LoopField = "2" ? "..--- " : A_LoopField = "3" ? "...-- " : A_LoopField = "4" ? "....- " : A_LoopField = "5" ? "..... " : A_LoopField = "6" ? "-.... " : A_LoopField = "7" ? "--... " : A_LoopField = "8" ? "---.. " : A_LoopField = "9" ? "----. " : A_LoopField = ":" ? "---... " : A_LoopField = ";" ? "-.-.-. " : A_LoopField = "=" ? "-...- " : A_LoopField = "?" ? "..--.. " : A_LoopField = "@" ? ".--.-. " : A_LoopField = "[" ? "-.--. " : A_LoopField = "]" ? "-.--.- " : A_LoopField = "_" ? "..--.- " : "ERROR" ; ---End conversion loop---
	Loop, Parse, morse
	{
		morsebeep := 120
		if (A_LoopField = ".")
			SoundBeep, 10*morsebeep, morsebeep		;Format: SoundBeep, frequency, duration
		If (A_LoopField = "-")
			SoundBeep, 10*morsebeep, 3*morsebeep	;Duration can be an expression
		If (A_LoopField = " ")
			Sleep, morsebeep					;Above, each character is followed by a space, and literal
	}									;Spaces are extended. Sleep pauses the script
	return morse								;Returns the text in morse code
} ;                                                         ---End Function Morse---


/*
Michal Sikorski
06/07/2016
*/
#include <cstdlib>
#include <iostream>
#include <windows.h>
#include <string.h>
using namespace std;
int main(int argc, char *argv[])
{
    string inpt;
    char ascii[28] = " ABCDEFGHIJKLMNOPQRSTUVWXYZ", lwcAscii[28] = " abcdefghijklmnopqrstuvwxyz";
    string morse[27] = {"  ", ".- ", "-... ", "-.-. ", "-.. ", ". ", "..-. ", "--. ", ".... ", ".. ", ".--- ", "-.- ", ".-.. ", "-- ", "-. ", "--- ", ".--.", "--.- ", ".-. ", "... ", "- ", "..- ", "...- ", ".-- ", "-..- ", "-.-- ", "--.. "};
    string outpt;
    getline(cin,inpt);
    int xx=0;
    int size = inpt.length();
    cout<<"Length:"<<size<<endl;

    xx=0;
    while(xx<inpt.length())
    {
                         int x=0;
                         bool working = false;
                         while(!working)
                         {
                                  if(ascii[x] != inpt[xx]&&lwcAscii[x] != inpt[xx])
                                  {
                                        x++;
                                  }
                                  else
                                  {
                                        working = !working;
                                  }
                         }

                         cout<<morse[x];
                         outpt = outpt + morse[x];
                         xx++;
    }

    xx=0;
    while(xx<outpt.length()+1)
    {
                         if(outpt[xx] == '.')
                         {
                                   Beep(1000,250);
                         }
                         else
                         {
                             if(outpt[xx] == '-')
                             {
                                          Beep(1000,500);
                             }
                             else
                             {
                                 if(outpt[xx] == ' ')
                                 {
                                              Sleep(500);
                                 }
                             }
                         }
                         xx++;
    }
    system("PAUSE");
    return EXIT_SUCCESS;
}


(import [javax.sound.sampled AudioFormat AudioSystem SourceDataLine])

(defn play [sample-rate bs]
  (let [af (AudioFormat. sample-rate 8 1 true true)]
    (doto (AudioSystem/getSourceDataLine af)
      (.open af sample-rate)
      .start
      (.write bs 0 (count bs))
      .drain
      .close)))

(defn note [hz sample-rate ms]
  (let [period (/ hz sample-rate)]
    (->> (range (* sample-rate ms 1/1000))
	 (map #(->> (* 2 Math/PI % period)
		    Math/sin
		    (* 127 ,)
		    byte) ,))))

(def morse-codes
     {\A ".-"   \J ".---" \S "..."   \1 ".----" \. ".-.-.-" \: "---..."
      \B "-..." \K "-.-"  \T "-"     \2 "..---" \, "--..--" \; "-.-.-."
      \C "-.-." \L ".-.." \U "..-"   \3 "...--" \? "..--.." \= "-...-"
      \D "-.."  \M "--"   \V "...-"  \4 "....-" \' ".----." \+ ".-.-."
      \E "."    \N "-."   \W ".--"   \5 "....." \! "-.-.--" \- "-....-"
      \F "..-." \O "---"  \X "-..-"  \6 "-...." \/ "-..-."  \_ "..--.-"
      \G "--."  \P ".--." \Y "-.--"  \7 "--..." \( "-.--."  \" ".-..-."  ;"
      \H "...." \Q "--.-" \Z "--.."  \8 "---.." \) "-.--.-" \$ "...-..-"
      \I ".."   \R ".-."  \0 "-----" \9 "----." \& ".-..."  \@ ".--.-."
      \space " "})

(def sample-rate 1024)

(let [hz 440
      ms 50]
  (def sounds
       {\. (note hz sample-rate (* 1 ms))
	\- (note hz sample-rate(* 3 ms))
	:element-gap (note 0 sample-rate (* 1 ms))
	:letter-gap (note 0 sample-rate (* 3 ms))
	\space (note 0 sample-rate (* 1 ms))})) ;includes letter-gap on either side

(defn convert-letter [letter]
  (->> (get morse-codes letter "")
       (map sounds ,)
       (interpose (:element-gap sounds) ,)
       (apply concat ,)))

(defn morse [s]
  (->> (.toUpperCase s)
       (map convert-letter ,)
       (interpose (:letter-gap sounds) ,)
       (apply concat ,)
       byte-array
       (play sample-rate ,)))


class Morse
  constructor : (@unit=0.05, @freq=700) ->

    @cont = new AudioContext()
    @time = @cont.currentTime
    @alfabet = "..etianmsurwdkgohvf.l.pjbxcyzq..54.3...2.......16.......7...8.90"

  getCode : (letter) ->
    i = @alfabet.indexOf letter
    result = ""
    while i > 1
      result = ".-"[i%2] + result
      i //= 2
    result

  makecode : (data) ->
    for letter in data
      code = @getCode letter
      if code != undefined then @maketime code else @time += @unit * 7

  maketime : (data) ->
    for timedata in data
      timedata = @unit * ' . _'.indexOf timedata
      if timedata > 0
        @maketone timedata
        @time += timedata
        @time += @unit * 1
    @time += @unit * 2

  maketone : (data) ->
    start = @time
    stop = @time + data
    @gain.gain.linearRampToValueAtTime 0, start
    @gain.gain.linearRampToValueAtTime 1, start + @unit / 8
    @gain.gain.linearRampToValueAtTime 1, stop - @unit / 16
    @gain.gain.linearRampToValueAtTime 0, stop

  send : (text) ->
    osci = @cont.createOscillator()
    osci.frequency.value = @freq
    @gain = @cont.createGain()
    @gain.gain.value = 0
    osci.connect @gain
    @gain.connect @cont.destination

    osci.start @time
    @makecode text
    @cont

morse = new Morse()
morse.send 'hello world 0123456789'


program Morse;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.Generics.Collections,
  SysUtils,
  Windows;

const
  Codes: array[0..35, 0..1] of string =
   (('a', '.-   '), ('b', '-... '), ('c', '-.-. '), ('d', '-..  '),
    ('e', '.    '), ('f', '..-. '), ('g', '--.  '), ('h', '.... '),
    ('i', '..   '), ('j', '.--- '), ('k', '-.-  '), ('l', '.-.. '),
    ('m', '--   '), ('n', '-.   '), ('o', '---  '), ('p', '.--. '),
    ('q', '--.- '), ('r', '.-.  '), ('s', '...  '), ('t', '-    '),
    ('u', '..-  '), ('v', '...- '), ('w', '.--  '), ('x', '-..- '),
    ('y', '-.-- '), ('z', '--.. '), ('0', '-----'), ('1', '.----'),
    ('2', '..---'), ('3', '...--'), ('4', '....-'), ('5', '.....'),
    ('6', '-....'), ('7', '--...'), ('8', '---..'), ('9', '----.'));
var
  Dictionary: TDictionary<String, String>;

procedure InitCodes;
var
  i: Integer;
begin
  for i := 0 to High(Codes) do
    Dictionary.Add(Codes[i, 0], Codes[i, 1]);
end;

procedure SayMorse(const Word: String);
var
  s: String;
begin
  for s in Word do
    if s = '.' then
      Windows.Beep(1000, 250)
    else if s = '-' then
      Windows.Beep(1000, 750)
    else
      Windows.Beep(1000, 1000);
end;

procedure ParseMorse(const Word: String);
var
  s, Value: String;
begin
  for s in word do
    if Dictionary.TryGetValue(s, Value) then
    begin
      Write(Value + ' ');
      SayMorse(Value);
    end;
end;

begin
  Dictionary := TDictionary<String, String>.Create;
  try
    InitCodes;
    if ParamCount = 0 then
      ParseMorse('sos')
    else if ParamCount = 1 then
      ParseMorse(LowerCase(ParamStr(1)))
    else
      Writeln('Usage: Morse.exe anyword');

    Readln;
  finally
    Dictionary.Free;
  end;
end.


HEX
\ PC speaker hardware control (requires GIVEIO or DOSBOX for windows operation)
 042 constant fctrl
 043 constant tctrl
 061 constant sctrl
 0FC constant smask

\ [email protected] is Port char fetch (Intel IN instruction).  PC! is port char store (Intel OUT instruction)
: speak     ( -- ) sctrl [email protected]               03 or  sctrl pc! ;
: silence   ( -- ) sctrl [email protected]   smask and   01 or  sctrl pc! ;

: tone     ( freq -- )                 \ freq is actually just a divisor value
            ?dup                       \ check for non-zero input
            if   0B6 tctrl pc!         \ enable PC speaker
                 dup fctrl pc!         \ set freq
                 8 rshift fctrl pc!
                 speak
            else
                 silence
            then ;

\ morse demonstration begins here
DECIMAL
1000 value freq                        \ arbitrary value that sounded ok
  90 value adit                        \ 1 dit will be 90 ms

: dit_dur      adit ms ;
: dah_dur      adit 3 * ms ;
: wordgap      adit 5 * ms ;
: off_dur      adit 2/ ms ;
: lettergap    dah_dur ;

: sound ( -- ) freq tone ;

: MORSE-EMIT  ( char -- )
        dup  bl =                      \ check for space character
        if
             wordgap drop              \ and delay if detected
        else
             pad C!                    \ write char to buffer
             pad 1 evaluate            \ evaluate 1 character
             lettergap                 \ pause for correct sounding morse code
        then ;

: TRANSMIT ( ADDR LEN -- )
           cr                          \ newline,
           bounds                      \ convert loop indices to address ranges
           do
              I [email protected] dup emit            \ dup and send char to console
              morse-emit               \ send the morse code
           loop ;

VOCABULARY MORSE                       \ prevent name conflicts with letters and numbers

MORSE DEFINITIONS                      \ the following definitions go into MORSE namespace
: .   ( -- ) sound  dit_dur  silence off_dur ;
: -   ( -- ) sound  dah_dur  silence off_dur ;

\ define morse letters as Forth words. They transmit when executed

: A  . -  ;     : B  - . . . ;   : C  - . - . ;    : D  - . . ;
: E  . ;        : F  . . - . ;   : G  - - . ;      : H  . . . . ;
: I  . . ;      : J  . - - - ;   : K  - . - ;      : L  . - . . ;
: M  - - ;      : N  - . ;       : O  - - - ;      : P  . - - . ;
: Q  - - . - ;  : R  . - . ;     : S  . . . ;      : T  - ;
: U  . . - ;    : V  . . . - ;   : W  . - - ;      : X  - . . - ;
: Y  - . - - ;  : Z  - - . . ;

: 0  - - - - - ;     : 1  . - - - - ;
: 2  . . - - - ;     : 3  . . . - - ;
: 4  . . . . - ;     : 5  . . . . . ;
: 6  - . . . . ;     : 7  - - . . . ;
: 8  - - - . . ;     : 9  - - - - . ;

: '  - . . - . ;
: \  . - - - . ;
: !  . - . - . ;
: ?  . . - - . . ;
: ,  - - . . - - ;
: /   - . . - . ;
: .  . - . - . - ;

 PREVIOUS DEFINITIONS                   \ go back to previous namespace
: TRANSMIT   MORSE  TRANSMIT  PREVIOUS ;


'Requires component 'gb.sdl2.audio'

Public Sub Main()
Dim sMessage As String = "Hello World"
Dim sFile As String = File.Load("../morse.txt") 'Contains A,.- B,-... etc
Dim sChar As New String[]
Dim sMorse As New String[]
Dim sOutPut As New String[]
Dim sTemp As String
Dim siCount, siLoop As Short
Dim bTrigger As Boolean
Dim fDelay As Float = 0.4

If Not Exist("/tmp/dot.ogg") Then Copy "../dot.ogg" To "/tmp/dot.ogg"     'Sounds downloaded from
If Not Exist("/tmp/dash.ogg") Then Copy "../dash.ogg" To "/tmp/dash.ogg"  'https://en.wikipedia.org/wiki/Morse_code#Letters.2C_numbers.2C_punctuation.2C_prosigns_for_Morse_code_and_non-English_variants

For Each sTemp In Split(sFile, gb.NewLine)
  sChar.add(Split(Trim(sTemp))[0])
  sMorse.add(Split(Trim(sTemp))[1])
Next

For siCount = 1 To Len(sMessage)
  For siLoop = 0 To sChar.Max
    If sChar[siLoop] = Mid(UCase(sMessage), siCount, 1) Then
      sOutPut.Add(sMorse[siLoop])
      bTrigger = True
      Break
    End If
  Next
  If bTrigger = False Then sOutPut.Add(" ")
  bTrigger = False
Next

Print sOutPut.Join(" ")

For siCount = 0 To Len(sMessage) - 1
  For siLoop = 0 To Len(sOutPut[siCount]) - 1
    If Mid(sOutPut[siCount], siLoop + 1, 1) = "." Then
      Music.Load("/tmp/dot.ogg")
      Music.Play
      Wait fDelay
    Else If Mid(sOutPut[siCount], siLoop + 1, 1) = "-" Then
      Music.Load("/tmp/dash.ogg")
      Music.Play
      Wait fDelay
    Else
      Wait fDelay
    Endif
  Next
Next

End


// Command morse translates an input string into morse code,
// showing the output on the console, and playing it as sound.
// Only works on ubuntu.
package main

import (
	"flag"
	"fmt"
	"log"
	"regexp"
	"strings"
	"syscall"
	"time"
	"unicode"
)

// A key represents an action on the morse key.
// It's either on or off, for the given duration.
type key struct {
	duration int
	on       bool
	sym      string // for debug output
}

var (
	runeToKeys   = map[rune][]key{}
	interCharGap = []key{{1, false, ""}}
	punctGap     = []key{{7, false, " / "}}
	charGap      = []key{{3, false, " "}}
	wordGap      = []key{{7, false, " / "}}
)

const rawMorse = `
A:.-    J:.---  S:...    1:.----  .:.-.-.-  ::---...
B:-...  K:-.-   T:-      2:..---  ,:--..--  ;:-.-.-.
C:-.-.  L:.-..  U:..-    3:...--  ?:..--..  =:-...-
D:-..   M:--    V:...-   4:....-  ':.----.  +:.-.-.
E:.     N:-.    W:.--    5:.....  !:-.-.--  -:-....-
F:..-.  O:---   X:-..-   6:-....  /:-..-.   _:..--.-
G:--.   P:.--.  Y:-.--   7:--...  (:-.--.   ":.-..-.
H:....  Q:--.-  Z:--..   8:---..  ):-.--.-  $:...-..-
I:..    R:.-.   0:-----  9:----.  &:.-...   @:.--.-.
`

func init() {
	// Convert the rawMorse table into a map of morse key actions.
	r := regexp.MustCompile("([^ ]):([.-]+)")
	for _, m := range r.FindAllStringSubmatch(rawMorse, -1) {
		c := m[1][0]
		keys := []key{}
		for i, dd := range m[2] {
			if i > 0 {
				keys = append(keys, interCharGap...)
			}
			if dd == '.' {
				keys = append(keys, key{1, true, "."})
			} else if dd == '-' {
				keys = append(keys, key{3, true, "-"})
			} else {
				log.Fatalf("found %c in morse for %c", dd, c)
			}
			runeToKeys[rune(c)] = keys
			runeToKeys[unicode.ToLower(rune(c))] = keys
		}
	}
}

// MorseKeys translates an input string into a series of keys.
func MorseKeys(in string) ([]key, error) {
	afterWord := false
	afterChar := false
	result := []key{}
	for _, c := range in {
		if unicode.IsSpace(c) {
			afterWord = true
			continue
		}
		morse, ok := runeToKeys[c]
		if !ok {
			return nil, fmt.Errorf("can't translate %c to morse", c)
		}
		if unicode.IsPunct(c) && afterChar {
			result = append(result, punctGap...)
		} else if afterWord {
			result = append(result, wordGap...)
		} else if afterChar {
			result = append(result, charGap...)
		}
		result = append(result, morse...)
		afterChar = true
		afterWord = false
	}
	return result, nil
}

func main() {
	var ditDuration time.Duration
	flag.DurationVar(&ditDuration, "d", 40*time.Millisecond, "length of dit")
	flag.Parse()
	in := "hello world."
	if len(flag.Args()) > 1 {
		in = strings.Join(flag.Args(), " ")
	}
	keys, err := MorseKeys(in)
	if err != nil {
		log.Fatalf("failed to translate: %s", err)
	}
	for _, k := range keys {
		if k.on {
			if err := note(true); err != nil {
				log.Fatalf("failed to play note: %s", err)
			}
		}
		fmt.Print(k.sym)
		time.Sleep(ditDuration * time.Duration(k.duration))
		if k.on {
			if err := note(false); err != nil {
				log.Fatalf("failed to stop note: %s", err)
			}
		}
	}
	fmt.Println()
}

// Implement sound on ubuntu. Needs permission to access /dev/console.

var consoleFD uintptr

func init() {
	fd, err := syscall.Open("/dev/console", syscall.O_WRONLY, 0)
	if err != nil {
		log.Fatalf("failed to get console device: %s", err)
	}
	consoleFD = uintptr(fd)
}

const KIOCSOUND = 0x4B2F
const clockTickRate = 1193180
const freqHz = 600

// note either starts or stops a note.
func note(on bool) error {
	arg := uintptr(0)
	if on {
		arg = clockTickRate / freqHz
	}
	_, _, errno := syscall.Syscall(syscall.SYS_IOCTL, consoleFD, KIOCSOUND, arg)
	if errno != 0 {
		return errno
	}
	return nil

}


import System.IO
import MorseCode
import MorsePlaySox

-- Read standard input, converting text to Morse code, then playing the result.
-- We turn off buffering on stdin so it will play as you type.
main = do
  hSetBuffering stdin NoBuffering
  text <- getContents
  play $ toMorse text