var globalAudioContext = new webkitAudioContext();

function morsecode(text, unit, freq) {
	'use strict';

	// defaults
	unit = unit ? unit : 0.05;
	freq = freq ? freq : 700;
	var cont = globalAudioContext;
	var time = cont.currentTime;

	// morsecode
	var code = {
		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: '____.'
	};

	// generate code for text
	function makecode(data) {
		for (var i = 0; i <= data.length; i ++) {
			var codedata = data.substr(i, 1).toLowerCase();
			codedata = code[codedata];
			// recognised character
			if (codedata !== undefined) {
				maketime(codedata);
			}
			// unrecognised character
			else {
				time += unit * 7;
			}
		}
	}

	// generate time for code
	function maketime(data) {
		for (var i = 0; i <= data.length; i ++) {
			var timedata = data.substr(i, 1);
			timedata = (timedata === '.') ? 1 : (timedata === '_') ? 3 : 0;
			timedata *= unit;
			if (timedata > 0) {
				maketone(timedata);
				time += timedata;
				// tone gap
				time += unit * 1;
			}
		}
		// char gap
		time += unit * 2;
	}

	// generate tone for time
	function maketone(data) {
		var start = time;
		var stop = time + data;
		// filter: envelope the tone slightly
		gain.gain.linearRampToValueAtTime(0, start);
		gain.gain.linearRampToValueAtTime(1, start + (unit / 8));
		gain.gain.linearRampToValueAtTime(1, stop - (unit / 16));
		gain.gain.linearRampToValueAtTime(0, stop);
	}

	// create: oscillator, gain, destination
	var osci = cont.createOscillator();
	osci.frequency.value = freq;
	var gain = cont.createGainNode();
	gain.gain.value = 0;
	var dest = cont.destination;
	// connect: oscillator -> gain -> destination
	osci.connect(gain);
	gain.connect(dest);
	// start oscillator
	osci.start(time);

	// begin encoding: text -> code -> time -> tone
	makecode(text);

	// return web audio context for reuse / control
	return cont;
}


import javax.sound.sampled.AudioFormat
import javax.sound.sampled.AudioSystem

val morseCode = hashMapOf(
        'a' to ".-", 'b' to "-...", 'c' to "-.-.",
        'd' to "-..", 'e' to ".", 'f' to "..-.",
        'g' to "--.", 'h' to "....", 'i' to "..",
        'j' to ".---", 'k' to "-.-", 'l' to ".-..",
        'm' to "--", 'n' to "-.", 'o' to "---",
        'p' to ".--.", 'q' to "--.-", 'r' to ".-.",
        's' to "...", 't' to "-", 'u' to "..-",
        'v' to "...-", 'w' to ".--", 'x' to "-..-",
        'y' to "-.--", 'z' to "--..",

        '0' to ".....", '1' to "-....", '2' to "--...",
        '3' to "---..", '4' to "----.", '5' to "-----",
        '6' to ".----", '7' to "..---", '8' to "...--",
        '9' to "....-",

        ' ' to "/", ',' to "--..--", '!' to "-.-.--",
        '"' to ".-..-.", '.' to ".-.-.-", '?' to "..--..",
        '\'' to ".----.", '/' to "-..-.", '-' to "-....-",
        '(' to "-.--.-", ')' to "-.--.-"
)

val symbolDurationInMs = hashMapOf('.' to 200, '-' to 500, '/' to 1000)

fun toMorseCode(message: String) = message.filter { morseCode.containsKey(it) }
                                          .fold("") { acc, ch -> acc + morseCode[ch]!! }

fun playMorseCode(morseCode: String) = morseCode.forEach { symbol -> beep(symbolDurationInMs[symbol]!!) }

fun beep(durationInMs: Int) {
    val soundBuffer = ByteArray(durationInMs * 8)
    for ((i, _) in soundBuffer.withIndex()) {
        soundBuffer[i] = (Math.sin(i / 8.0 * 2.0 * Math.PI) * 80.0).toByte()
    }

    val audioFormat = AudioFormat(
            /*sampleRate*/ 8000F,
            /*sampleSizeInBits*/ 8,
            /*channels*/ 1,
            /*signed*/ true,
            /*bigEndian*/ false
    )
    with (AudioSystem.getSourceDataLine(audioFormat)!!) {
        open(audioFormat)

        start()
        write(soundBuffer, 0, soundBuffer.size)
        drain()

        close()
    }
}

fun main(args: Array<String>) {
    args.forEach {
        playMorseCode(toMorseCode(it.toLowerCase()))
    }
}


'The following code relies on the Windows API
Input "Input the text to translate to Morse Code... "; string$
Print PlayMorse$(string$)
End

Function PlayMorse$(string$)
    'LetterGap = (3 * BaseTime)
    'WordGap = (7 * BaseTime)
    BaseTime = 50
    freq = 1250
    PlayMorse$ = TranslateToMorse$(string$)
    morseCode$ = "./-"
    For i = 1 To Len(PlayMorse$)
        Scan
        dwDuration = (Instr(morseCode$, Mid$(PlayMorse$, i, 1)) * BaseTime)
        If (Mid$(PlayMorse$, i, 1) <> " ") Then
            CallDLL #kernel32, "Beep", freq As ulong, dwDuration As ulong, ret As long
            CallDLL #kernel32, "Sleep", BaseTime As long, ret As void
        End If
        If (Mid$(PlayMorse$, i, 1) <> " ") Then
            sleep = (3 * BaseTime)
        Else
            sleep = (7 * BaseTime)
        End If
        CallDLL #kernel32, "Sleep", sleep As long, ret As void
    Next i
End Function

Function TranslateToMorse$(string$)
    string$ = Upper$(string$)
    For i = 1 To Len(string$)
        While desc$ <> "End"
            Read desc$, value$
            If desc$ = "" Then desc$ = chr$(34)
            If desc$ = Mid$(string$, i, 1) Then
                If Mid$(string$, i, 1) <> " " Then value$ = " " + value$
                TranslateToMorse$ = TranslateToMorse$ + value$
                Exit While
            End If
        Wend
        If desc$ = "End" Then Notice Mid$(string$, i, 1) + " is not accounted for in the Morse Code Table."
        Restore
    Next i
    TranslateToMorse$ = Trim$(TranslateToMorse$)
    Data "A", ".-", "B", "-...", "C", "-.-.", "D", "-..", "E", ".", "F", "..-.", "G", "--."
    Data "H", "....", "I", "..", "J", ".---", "K", "-.-", "L", ".-..", "M", "--", "N", "-."
    Data "O", "---", "P", ".--.", "Q", "--.-", "R", ".-.", "S", "...", "T", "-", "U", "..-"
    Data "V", "...-", "W", ".--", "X", "-..-", "Y", "-.--", "Z", "--..", "Á", "--.-", "Ä", ".-.-"
    Data "É", "..-..", "Ñ", "--.--", "Ö", "---.", "Ü", "..--", "1", ".----", "2", "..---"
    Data "3", "...--", "4", "....-", "5", ".....", "6", "-....", "7", "--...", "8", "---.."
    Data "9", "----.", "0", "-----", ",", "--..--", ".", ".-.-.-", "?", "..--..", ";", "-.-.-"
    Data ":", "---...", "/", "-..-.", "-", "-....-", "'", ".----.", "+", ".-.-.", "", ".-..-."
    Data "@", ".--.-.", "(", "-.--.", ")", "-.--.-", "_", "..--.-", "$", "...-..-", "&", ".-..."
    Data "=", "-...-", "!", "..--.", " ", " ", "End", ""
End Function


local M = {}

-- module-local variables
local BUZZER = pio.PB_10
local dit_length, dah_length, word_length

-- module-local functions
local buzz, dah, dit, init, inter_element_gap, medium_gap, pause, sequence, short_gap

buzz = function(duration)
  pio.pin.output(BUZZER)
  pio.pin.setlow(BUZZER)
  tmr.delay(tmr.SYS_TIMER, duration)
  pio.pin.sethigh(BUZZER)
  pio.pin.input(BUZZER)
end

dah = function()
  buzz(dah_length)
end

dit = function()
  buzz(dit_length)
end

init = function(baseline)
  dit_length = baseline
  dah_length = 2 * baseline
  word_length = 4 * baseline
end

inter_element_gap = function()
  pause(dit_length)
end

medium_gap = function()
  pause(word_length)
end

pause = function(duration)
  tmr.delay(tmr.SYS_TIMER, duration)
end

sequence = function(codes)
  if codes then
    for _,f in ipairs(codes) do
      f()
      inter_element_gap()
    end
    short_gap()
  end
end

short_gap = function()
  pause(dah_length)
end

local morse = {
  a = { dit, dah }, b = { dah, dit, dit, dit }, c = { dah, dit, dah, dit },
  d = { dah, dit, dit }, e = { dit }, f = { dit, dit, dah, dit },
  g = { dah, dah, dit }, h = { dit, dit, dit ,dit }, i = { dit, dit },
  j = { dit, dah, dah, dah }, k = { dah, dit, dah }, l = { dit, dah, dit, dit },
  m = { dah, dah }, n = { dah, dit }, o = { dah, dah, dah },
  p = { dit, dah, dah, dit }, q = { dah, dah, dit, dah }, r = { dit, dah, dit },
  s = { dit, dit, dit }, t = { dah }, u = { dit, dit, dah },
  v = { dit, dit, dit, dah }, w = { dit, dah, dah }, x = { dah, dit, dit, dah },
  y = { dah, dit, dah, dah }, z = { dah, dah, dit, dit },

  ["0"] = { dah, dah, dah, dah, dah }, ["1"] = { dit, dah, dah, dah, dah },
  ["2"] = { dit, dit, dah, dah, dah }, ["3"] = { dit, dit, dit, dah, dah },
  ["4"] = { dit, dit, dit, dit, dah }, ["5"] = { dit, dit, dit, dit, dit },
  ["6"] = { dah, dit, dit, dit, dit }, ["7"] = { dah, dah, dit, dit, dit },
  ["8"] = { dah, dah, dah, dit, dit }, ["9"] = { dah, dah, dah, dah, dit },

  [" "] = { medium_gap }
}

-- public interface
M.beep = function(message)
  message = message:lower()
  for _,ch in ipairs { message:byte(1, #message) } do
    sequence(morse[string.char(ch)])
  end
end

M.set_dit = function(duration)
  init(duration)
end

-- initialization code
init(50000)

return M


Dictionary = Join[CharacterRange["a", "z"], CharacterRange["0", "9"]];
mark = 0.1; gap = 0.125; (* gap should be equal to mark. But longer gap makes audio code easier to decode *)
shortgap = 3*gap; medgap = 7*gap;
longmark = 3*mark;
MorseDictionary = {
   ".-", "-...", "-.-.", "-..",
   ".", "..-.", "--.", "....", "..",
   ".---", "-.-", ".-..", "--", "-.",
   "---", ".--.", "--.-", ".-.",
   "...", "-", "..-", "...-", ".--",
   "-..-", "-.--", "--..",
   "-----", ".----", "..---", "...--", "....-", ".....",
   "-....", "--...", "---..", "----."
   };

MorseDictionary = # <> " " & /@ MorseDictionary; (* Force short gap silence after each letter/digit *)

Tones = {
   SoundNote[None, medgap],
   SoundNote[None, shortgap],
   {SoundNote["C", mark, "Clarinet"], SoundNote[None, gap]},
   {SoundNote["C", longmark, "Clarinet"], SoundNote[None, gap]},
   {SoundNote["F#", mark, "Clarinet"], SoundNote[None, gap]}  (* Use F# short mark to denote unrecognized character *)
   };

codeRules = MapThread[Rule, {Dictionary, MorseDictionary}];
decodeRules = MapThread[Rule, {MorseDictionary, Dictionary}];
soundRules = MapThread[Rule, {{"  ", " ", ".", "-", "?"}, Tones}];
(* The order of the rules here is important. Otherwise medium gaps and short gaps get confounded *)

morseCode[s_String] := StringReplace[[email protected], codeRules~Join~{x_ /; FreeQ[[email protected]{Dictionary, " "}, x] -> "? "}]
morseDecode[s_String] := StringReplace[s, decodeRules]
sonicMorse[s_String] := [email protected]@Flatten[[email protected]@s /. soundRules]


MODULE MorseCode;
FROM Terminal IMPORT WriteString,WriteLn,ReadChar;

PROCEDURE WriteMorseCode(str : ARRAY OF CHAR);
VAR i : CARDINAL;
BEGIN
    WriteString(str);
    WriteLn;
    FOR i:=0 TO HIGH(str) DO
        CASE CAP(str[i]) OF
              'A': WriteString(".-");
            | 'B': WriteString("-...");
            | 'C': WriteString("-.-");
            | 'D': WriteString("-..");
            | 'E': WriteString(".");
            | 'F': WriteString("..-.");
            | 'G': WriteString("--.");
            | 'H': WriteString("....");
            | 'I': WriteString("..");
            | 'J': WriteString(".---");
            | 'K': WriteString("-.-");
            | 'L': WriteString(".-..");
            | 'M': WriteString("--");
            | 'N': WriteString("-.");
            | 'O': WriteString("---");
            | 'P': WriteString(".--.");
            | 'Q': WriteString("--.-");
            | 'R': WriteString(".-.");
            | 'S': WriteString("...");
            | 'T': WriteString("-");
            | 'U': WriteString("..-");
            | 'V': WriteString("...-");
            | 'W': WriteString(".--");
            | 'X': WriteString("-..-");
            | 'Y': WriteString("-.--");
            | 'Z': WriteString("--..");
            | '0': WriteString("-----");
            | '1': WriteString(".----");
            | '2': WriteString("..---");
            | '3': WriteString("...--");
            | '4': WriteString("....-");
            | '5': WriteString(".....");
            | '6': WriteString("-....");
            | '7': WriteString("--...");
            | '8': WriteString("---..");
            | '9': WriteString("----.");
            | ' ': WriteString("  ");
        ELSE
            IF (str[i] # 0C) THEN
                WriteString("?");
            END
        END;
        WriteString(" ");
    END;
END WriteMorseCode;

BEGIN
    WriteMorseCode("hello world");
    WriteLn;

    ReadChar;
END MorseCode.


{$mode delphi}
PROGRAM cw;
		// Output a string as Morse code and CW.
		// Cross-platform PCM audio uses OpenAL
USES 	OpenAL, HRTimer;

		// Intl. Morse codes in ASCII order
CONST  	Morse: ARRAY [32..95] OF STRING = (' ','-.-.--','.-..-.','#','...-..-','%','.-...','.----.','-.--.','-.--.-','*','.-.-.','--..--','-....-','.-.-.-','-..-.','-----','.----','..---','...--','....-','.....','-....','--...','---..','----.','---...','-.-.-.','>','-...-','<','..--..','.--.-.','.-','-...','-.-.','-..','.','..-.','--.','....','..','.---','-.-','.-..','--','-.','---','.--.','--.-','.-.','...','-','..-','...-','.--','-..-','-.--','--..','-.--.','\','-.--.-','~','..--.-');
		// lengthen dah by this fraction of dit:
		// best = 0.4; also lengthens pauses
		doh = 0.4;
		// an 0.05 sec dit is around 26 wpm
		dit = 0.05;
		dah = 3 * dit + doh * dit;

VAR 	// OpenAL variables
		buffer : TALuint;
		source : TALuint;
		sourcepos: ARRAY [0..2] OF TALfloat= ( 0.0, 0.0, 0.0 );
		sourcevel: ARRAY [0..2] OF TALfloat= ( 0.0, 0.0, 0.0 );

		argv: ARRAY OF PalByte;
		format: TALEnum;
		size: TALSizei;
		freq: TALSizei;
		loop: TALInt;
		data: TALVoid;

		// rewinding has an effect on the output:
		// <with> and <without> sound rather different
		rewind	: BOOLEAN = FALSE;
		// the high-res timer is from Wolfgang Ehrhardt
		// http://www.wolfgang-ehrhardt.de/misc_en.html
		t		: THRTimer;
		msg		: STRING = 'the quick brown fox jumps over the lazy dog.';

	PROCEDURE PlayS(s: Extended);
		BEGIN
			StartTimer(t);
			AlSourcePlay(source);
			WHILE readseconds(t) < s DO BEGIN END;
			IF rewind THEN AlSourceRewind(source);
			AlSourceStop(source);
		END;

	PROCEDURE Pause(s: Extended);
		BEGIN
			StartTimer(t);
			WHILE readseconds(t) < s DO BEGIN END;
		END;

	PROCEDURE doDit;
		BEGIN
			PlayS(dit);
			Pause(dit);
		END;

	PROCEDURE doDah;
		BEGIN
			PlayS(dah);
			Pause(dit);
		END;

	// ASCII char to Morse CW
	FUNCTION AtoM(ch: CHAR): STRING;
		VAR i: Integer;
			u: CHAR;
		BEGIN
			u := ch;
			IF ch IN ['a'..'z'] THEN u := chr(ord(ch) AND $5F);
			result := Morse[ord(u)];
			FOR i := 1 TO Length(result) DO
				CASE result[i] OF
					'.': BEGIN doDit; Write('. ') END;
					'-': BEGIN doDah; Write('_ ') END;
				END;
			Pause(dah);
			Write('  ');
			IF u = ' ' THEN Write('  ');
		END;

	// ASCII string to Morse CW
	PROCEDURE StoM(s: STRING);
		VAR i: Integer;
		BEGIN
			FOR i := 1 TO Length(s) DO AtoM(s[i]);
		END;

BEGIN
	// OpenAL preparation
	InitOpenAL;
	AlutInit(nil,argv);

	AlGenBuffers(1, @buffer);
	// load the 500 Hz 1 sec sine-wave file
	// get it from http://audiocheck.net
	AlutLoadWavFile('audiocheck.net_sin_500Hz_-3dBFS_1s.wav', format, data, size, freq, loop);
	AlBufferData(buffer, format, data, size, freq);
	AlutUnloadWav(format, data, size, freq);

	AlGenSources(1, @source);
	AlSourcei ( source, AL_BUFFER, buffer);
	AlSourcef ( source, AL_PITCH, 1.0 );
	AlSourcef ( source, AL_GAIN, 1.0 );
	AlSourcefv ( source, AL_POSITION, @sourcepos);
	AlSourcefv ( source, AL_VELOCITY, @sourcevel);
	AlSourcei ( source, AL_LOOPING, AL_TRUE);

	// Sound and print the Morse
	StoM(msg);
	Pause(1.0);

	AlSourceRewind(source);
	AlSourceStop(source);

	// Clean up
	AlDeleteBuffers(1, @buffer);
	AlDeleteSources(1, @source);
	AlutExit();
END.


use Acme::AGMorse qw(SetMorseVals SendMorseMsg);
SetMorseVals(20,30,400);
SendMorseMsg('Hello World! abcdefg @\;');  # note, caps are ingnored in Morse Code
exit;


--
-- demo\rosetta\Morse_code.exw
-- ===========================
--
with javascript_semantics
include pGUI.e
include builtins\beep.e

Ihandle input, canvas, output, vbox, dlg
cdCanvas cddbuffer, cdcanvas

constant title = "Morse code",
         help_text = """
Enter a message to convert to morse code.
Press Return to listen to the result.
Characters A-Z are shown with Baden-Powell menemonics.
(Note said are a memory aid, not perfectly readable.)
Obviously deliberately looking away and listening
would be the best way to use this as a learning aid.
"""

function show_help()
    IupMessage(title,help_text,bWrap:=false)
    IupSetFocus(input)
    return IUP_IGNORE -- (don't open the browser help!)
end function

constant morse_data = """
!-.-.--#".-..-.#$...-..-#&.-...#'.----.#(-.--.#)-.--.-#+.-.-.#,--..--#--....-#..-.-.-#/-..-.#=-...-#
0-----#1.----#2..---#3...--#4....-#5.....#6-....#7--...#8---..#9----.#:---...#;-.-.-.#?..--..#@.--.-.#
A.-51517525#B-...7177414144444747#C-.-.7121121277271616#D-..717741414747#E.7474#F..-.7171111174247777#
G--.712177271818#H....2121717127277777#I..51515757#J.---2121222558269668#K-.-742184854428#(-.--.#
L.-..7171727677771717#M--45118155#N-.71362727#O---712182861216#P.--.8181612164247777#)-.--.-#
Q--.-8286121677775818#R.-.717144261717#S...515154545757#T-7121#U..-818111117727#V...-8181111156567727#
W.--818187534317#X-..-8154333365654518#Y-.--8163545433115558#Z--..7121762277771717#_..--.-#     #"""

sequence morse = repeat(``,255), -- the eg "..."'s
        bdnpwl = repeat({},255) -- Baden-Powell mnemonics

procedure setMorse()
    -- I trust the characters and morse codes are all pretty evident in morse_data.
    -- Baden-Powell mnemonics are encoded as 4 points on a 9wx7h grid per dot/dash,
    -- counting (it just turned out that way) right to left and top to bottom, such
    -- that "9711" (=1197) is(/looks like) a forwardslash and "9117" a backslash.
    -- Each quite fiddly to set up - rather relieved there were only 26 of them!
    sequence data = split(substitute(morse_data,"\n",""),'#')
    for di in data do
        integer key = di[1]
        string bpm = trim_head(di[2..$],".- "),
              code = di[2..-length(bpm)-1]
        assert(length(bpm)=0 or length(bpm)=4*length(code))
        morse[key] = code   -- eg morse['S'] = "..."
        bdnpwl[key] = sq_sub('5',bpm)
    end for
    morse['['] = morse['(']
    morse[']'] = morse[')']
end procedure

setMorse()

function redraw_cb(Ihandle /*ih*/)
    string text = upper(IupGetAttribute(input,"VALUE")),
         outstr = ""
    integer {dw,dh} = IupGetIntInt(canvas, "DRAWSIZE"),
            {tw,th} = cdCanvasGetTextSize(cddbuffer,text)
    while tw>dw do
        if length(outstr) then outstr &= " " end if
        outstr &= morse[text[1]]
        text = text[2..$]
        {tw,th} = cdCanvasGetTextSize(cddbuffer,text)
    end while
    atom cw = tw/max(length(text),1),
         cx = dw/2,
         cy = dh/2

    cdCanvasActivate(cddbuffer)
    cdCanvasSetBackground(cddbuffer, CD_LIGHT_PARCHMENT)
    cdCanvasClear(cddbuffer)
    cdCanvasSetForeground(cddbuffer, #BBADA0)
    cdCanvasText(cddbuffer, cx, cy, text)
    cx -= cw*(length(text)/2-0.5)

    cdCanvasSetForeground(cddbuffer, CD_BLUE)
    cdCanvasSetLineWidth(cddbuffer,3)
    {} = cdCanvasMarkSize(cddbuffer,3)

    atom gw = cw*0.75, gh = th*0.285
    for ch in text do
        sequence bpm = bdnpwl[ch]
        if length(bpm) then
            for k=1 to length(bpm) by 4 do
                atom x1 = cx+gw*bpm[k+0]/8-1,
                     y1 = cy+gh*bpm[k+1]/4-3,
                     x2 = cx+gw*bpm[k+2]/8-1,
                     y2 = cy+gh*bpm[k+3]/4-3
                if x1=x2 and y1=y2 then
                    cdCanvasMark(cddbuffer, x1, y1)
                else
                    cdCanvasLine(cddbuffer, x1, y1, x2, y2)
                end if
            end for
        end if
        cx += cw
        if length(outstr) then outstr &= " " end if
        outstr &= morse[ch]
    end for
    cdCanvasFlush(cddbuffer)
    IupSetStrAttribute(output,"TITLE",outstr)
    return IUP_DEFAULT
end function

function map_cb(Ihandle ih)
    cdcanvas = cdCreateCanvas(CD_IUP, ih)
    cddbuffer = cdCreateCanvas(CD_DBUFFER, cdcanvas)
--  cdCanvasFont(cddbuffer,"Courier",CD_PLAIN,24)
    cdCanvasFont(cddbuffer,"Courier",CD_PLAIN,48)
    cdCanvasSetTextAlignment(cddbuffer, CD_CENTER)
    return IUP_DEFAULT
end function

constant frequency = 1280,          -- in Hz, 37..32767
         wpm = 15,                  -- words per minute
         dit = 1200/wpm,            -- in milliseconds
         dah = 3*dit,
         lettergap = 3*dit,
         wordgap = 7*dit

function key_cb(Ihandle /*dlg*/, atom c)
    if c=K_ESC then return IUP_CLOSE end if -- (standard practice for me)
    if c=K_F5 then return IUP_DEFAULT end if -- (let browser reload work)
    if c=K_F1 then return show_help() end if
    if c=K_CR then
        string text = trim(upper(IupGetAttribute(input,"VALUE")))
        sequence durations = {}
        for ch in text do
            if ch=' ' then
                durations &= wordgap
            else
                if length(durations) then
                    durations &= lettergap
                end if
                string m = morse[ch]
                for i=1 to length(m) do
                    if i>1 then durations &= dit end if
                    durations &= iff(m[i]='.'?dit:dah)
                end for
            end if
        end for
        beep(frequency,durations,0.5)
        IupSetAttribute(input,"SELECTION","ALL")
    elsif find(c,"#") then
        beep()
        return IUP_IGNORE
    else
        IupUpdate(canvas)
    end if
    return IUP_CONTINUE
end function

IupOpen()
input = IupText("EXPAND=HORIZONTAL")
canvas = IupCanvas("RASTERSIZE=520x40")
output = IupLabel("","EXPAND=HORIZONTAL")
vbox = IupVbox({input,canvas,output}, "MARGIN=10x5, GAP=5")
dlg = IupDialog(vbox,`TITLE="%s",MINSIZE=440x140`,{title})
IupSetCallback(dlg,"KEY_CB",Icallback("key_cb"))
IupSetCallbacks(canvas, {"MAP_CB", Icallback("map_cb"),
                         "ACTION", Icallback("redraw_cb")})
IupShow(dlg)
IupSetAttribute(canvas, "RASTERSIZE", NULL)
IupSetAttributeHandle(NULL,"PARENTDIALOG",dlg)
if platform()!=JS then
    IupMainLoop()
    IupClose()
end if


/* Sound Morse code via the PC buzzer.           June 2011 */
MORSE: procedure options (main);
   declare (i, j) fixed binary;
   declare buzz character (1) static initial ('07'x);
   declare text character (100) varying,
      c character (1);
   declare alphabet character (36) static initial (
      'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789');
   declare morse_character character(5) varying;
   declare morse_codes(36) character(5) varying static initial (
      /* Letters A-Z */
      '.-',    '-...',   '-.-.',   '-..',    '.',
      '..-.',  '--.',    '....',   '..',     '.---',
      '-.-',   '.-..',   '--',     '-.',     '---',
      '--.-',  '--.-',   '.-.',    '...',    '-',
      '..-',   '...-',   '.--',    '-..-',   '-.--',
      '--..',
      /* Digits 0-9 */
      '-----', '.----',  '..---', '...--',   '....-',
      '.....', '-....',  '--...', '---..',   '----.' );

   put skip list ('Please type the text to be transmitted:');
   get edit (text) (L);

   do i = 1 to length (text);
      c = substr(text, i, 1);
      j = index(alphabet, uppercase(c));
      if j > 0 then
         do;
            morse_character = morse_codes(j);
            put skip list (morse_character); /* Display the Morse. */
            call send_morse (morse_character);
         end;
   end;

send_morse: procedure (morse_character);
   declare morse_character character(*) varying;
   declare i fixed binary;

   do i = 1 to length(morse_character);
      if substr(morse_character, 1, 1) = '-' then
         put skip edit (buzz, ' ', buzz) (a(1), A, skip, a(1));
      else
         put skip edit (buzz, ' ') (a(1));
      delay (1000); /* Delay one period. */
   end;
   delay (1000);
      /* Making a delay of 2 periods after each English letter. */
end send_morse;

END MORSE;


function Send-MorseCode
{
    [CmdletBinding()]
    [OutputType([string])]
    Param
    (
        [Parameter(Mandatory=$true,
                   ValueFromPipeline=$true,
                   Position=0)]
        [string]
        $Message,

        [switch]
        $ShowCode
    )

    Begin
    {
        $morseCode = @{
            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 = "----."
        }
    }
    Process
    {
        foreach ($word in $Message)
        {
            $word.Split(" ",[StringSplitOptions]::RemoveEmptyEntries) | ForEach-Object {

                foreach ($char in $_.ToCharArray())
                {
                    if ($char -in $morseCode.Keys)
                    {
                        foreach ($code in ($morseCode."$char").ToCharArray())
                        {
                            if ($code -eq ".") {$duration = 250} else {$duration = 750}

                            [System.Console]::Beep(1000, $duration)
                            Start-Sleep -Milliseconds 50
                        }

                        if ($ShowCode) {Write-Host ("{0,-6}" -f ("{0,6}" -f $morseCode."$char")) -NoNewLine}
                    }
                }

                if ($ShowCode) {Write-Host}
            }

            if ($ShowCode) {Write-Host}
        }
    }
}


% convert text to morse
% query text2morse(Text, Morse)
% where
% Text is string to convert
% Morse is Morse representation
% There is a space between chars and double space between words
%
text2morse(Text, Morse) :-
	string_lower(Text, TextLower),			% rules are in lower case
	string_chars(TextLower, Chars),			% convert string into list of chars
	chars2morse(Chars, MorseChars),			% convert each char into morse
	string_chars(MorsePlusSpace, MorseChars),	% append returned string list into single string
	string_concat(Morse, ' ', MorsePlusSpace).	% Remove trailing space

chars2morse([], "").
chars2morse([H|CharTail], Morse) :-
	morse(H, M),
	chars2morse(CharTail, MorseTail),
	string_concat(M,' ', MorseSpace),
	string_concat(MorseSpace, MorseTail, Morse).

% space
morse(' ', " ").
% letters
morse('a', ".-").
morse('b', "-...").
morse('c', "-.-.").
morse('d', "-..").
morse('e', ".").
morse('f', "..-.").
morse('g', "--.").
morse('h', "....").
morse('i', "..").
morse('j', ".---").
morse('k', "-.-").
morse('l', ".-..").
morse('m', "--").
morse('n', "-.").
morse('o', "---").
morse('p', ".--.").
morse('q', "--.-").
morse('r', ".-.").
morse('s', "...").
morse('t', "-").
morse('u', "..-").
morse('v', "...-").
morse('w', ".--").
morse('x', "-..-").
morse('y', "-.--").
morse('z', "--..").
% numbers
morse('1', ".----").
morse('2', "..---").
morse('3', "...--").
morse('4', "....-").
morse('5', ".....").
morse('6', "-....").
morse('7', "--...").
morse('8', "---..").
morse('9', "----.").
morse('0', "-----").
% common punctuation
morse('.', ".-.-.-").
morse(',', "--..--").
morse('/', "-..-.").
morse('?', "..--..").
morse('=', "-...-").
morse('+', ".-.-.").
morse('-', "-....-").
morse('@', ".--.-.").


#BaseTime =50
#Frequence=1250
#Short    =   #BaseTime
#Long     =3* #BaseTime
#Intergap =   #BaseTime
#LetterGap=3* #BaseTime
#WordGap  =7* #BaseTime

Declare.s TextToMorse(Text$)
Declare.i PlayMorse(Text$)

Text$ =InputRequester("Morse coder","Enter text to send","Hello RosettaWorld!")
Text$ =TextToMorse(Text$)
If Not (InitSound() And PlayMorse(Text$))
  Text$=ReplaceString(Text$, ",","")
  MessageRequester("Morse EnCoded",Text$)
EndIf

;-
Procedure PlayMorse(Code$)    ;- Beep() is normally only Ok on Windows_x86
  CompilerIf #PB_Compiler_Processor=#PB_Processor_x86 And #PB_Compiler_OS=#PB_OS_Windows
    Protected i, sign
    For i=1 To Len(Code$)
      sign=Asc(Mid(Code$,i,1))
      Select sign
        Case '.': Beep_(#Frequence,#Short): Delay(#Intergap)
        Case '-': Beep_(#Frequence,#Long) : Delay(#Intergap)
        Case ',': Delay(#LetterGap)
        Case ' ': Delay(#WordGap)
      EndSelect
    Next
    ProcedureReturn 1
  CompilerElse
    ProcedureReturn 0
  CompilerEndIf
EndProcedure

Procedure.s TextToMorse(InString$)
  Protected *p.Character=@InString$, CurrStr$, i=1
  Protected.s s1, s2, result
  Repeat
    If Not *p\c: Break: EndIf
    CurrStr$=UCase(PeekS(*p,1))
    *p+StringByteLength(">")
    Restore MorseCode
    Repeat
      Read.s s1
      If s1="Done"
        s2+s1+" " ; failed to find this coding
        Break
      ElseIf Not s1=CurrStr$
        Continue
      EndIf
      Read.s s2
      result+s2
      If s2<>" "
        result+","
      EndIf
    ForEver
  ForEver
  ProcedureReturn result
EndProcedure

DataSection
  MorseCode:
  Data.s "A",  ".-"
  Data.s "B",  "-..."
  Data.s "C",  "-.-."
  Data.s "D",  "-.."
  Data.s "E",  "."
  Data.s "F",  "..-."
  Data.s "G",  "--."
  Data.s "H",  "...."
  Data.s "I",  ".."
  Data.s "J",  ".---"
  Data.s "K",  "-.-"
  Data.s "L",  ".-.."
  Data.s "M",  "--"
  Data.s "N",  "-."
  Data.s "O",  "---"
  Data.s "P",  ".--."
  Data.s "Q",  "--.-"
  Data.s "R",  ".-."
  Data.s "S",  "..."
  Data.s "T",  "-"
  Data.s "U",  "..-"
  Data.s "V",  "...-"
  Data.s "W",  ".--"
  Data.s "X",  "-..-"
  Data.s "Y",  "-.--"
  Data.s "Z",  "--.."
  Data.s "Á",  "--.-"
  Data.s "Ä",  ".-.-"
  Data.s "É",  "..-.."
  Data.s "Ñ",  "--.--"
  Data.s "Ö",  "---."
  Data.s "Ü",  "..--"
  Data.s "1",  ".----"
  Data.s "2",  "..---"
  Data.s "3",  "...--"
  Data.s "4",  "....-"
  Data.s "5",  "....."
  Data.s "6",  "-...."
  Data.s "7",  "--..."
  Data.s "8",  "---.."
  Data.s "9",  "----."
  Data.s "0",  "-----"
  Data.s ",",  "--..--"
  Data.s ".",  ".-.-.-"
  Data.s "?",  "..--.."
  Data.s ";",  "-.-.-"
  Data.s ":",  "---..."
  Data.s "/",  "-..-."
  Data.s "-",  "-....-"
  Data.s "'",  ".----."
  Data.s "+",  ".-.-."
  Data.s "-",  "-....-"
  Data.s #DOUBLEQUOTE$, ".-..-."
  Data.s "@",  ".--.-."
  Data.s "(",  "-.--."
  Data.s ")",  "-.--.-"
  Data.s "_",  "..--.-"
  Data.s "$",  "...-..-"
  Data.s "&",  ".-..."
  Data.s "=",  "---..."
  Data.s " ",  " "
  Data.s  "Done",""
  EndOfMorseCode:
EndDataSection


#lang racket
(require ffi/unsafe ffi/unsafe/define)
(define-ffi-definer defmm (ffi-lib "Winmm"))
(defmm midiOutOpen (_fun [h : (_ptr o _int32)] [_int = -1] [_pointer = #f]
                         [_pointer = #f] [_int32 = 0] -> _void -> h))
(defmm midiOutShortMsg (_fun _int32 _int32 -> _void))
(define M (midiOutOpen))
(define (midi x y z) (midiOutShortMsg M (+ x (* 256 y) (* 65536 z))))

(define raw-codes
  '("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--..|1.----"
    "|2..---|3...--|4....-|5.....|6-....|7--...|8---..|9----.|0-----"))

(define codes
  (for/list ([x (regexp-split #rx"\\|" (string-append* raw-codes))])
    (cons (string-ref x 0) (substring x 1))))

(define (morse str [unit 0.1])
  (define (sound len)
    (midi #x90 72 127) (sleep (* len unit))
    (midi #x90 72 0)   (sleep unit))
  (define (play str)
    (midi #xC0 #x35 0) ; use a cute voice
    (for ([c str])
      (case c [(#\.) (sound 1)] [(#\-) (sound 3)] [(#\ ) (sleep (* 3 unit))])))
  (let* ([str (string-foldcase str)]
         [str (regexp-replace* #rx"[,:;]+" str " ")]
         [str (regexp-replace* #rx"[.!?]+" str ".")]
         [str (string-normalize-spaces str)])
    (for ([s (string-split str)])
      (define m
        (string-join
         (for/list ([c s])
           (cond [(assq c codes) => cdr]
                 [else (case c [(#\space) " "] [(#\.) "  "] [else ""])]))))
      (printf "~a: ~a\n" s m)
      (play (string-append m "  ")))))

(morse "Say something here")


Red [
  file: %morse.red   ;; filename, could be ommited
]
; ";" is character for comment, i use double ones for better readability

DIT: 100 ;; constant : 100 ms for short Beep
FREQ: 700 ;; frequency for Beep

;; exported code for red/system win api calls to Beep / Sleep:
#include %api.reds

;; string with morse codes for alphabet:
;; ( caution, u must use "str: copy ..."  if code ist to be executed multiple times ! )
str: "A.-B-...C-.-.D-..E.F..-.G--.H....I..J.---K-.-L.-..M--N-."
append str "O---P.--.Q--.-R.-.S...T-U..-V...-W.--X-..-Y-.--Z--.."

 delim: charset [#"A" - #"Z"]

 ;; use of parse to generate "mc" morse code series / array containing codes for A - Z
 ;; use characters only as delimiter for each code
 mc:  parse str [ thru "A"  collect some [ keep copy result to [delim | end ] skip ] ]

  ;;--------------------------------------------
 send-code: func ["function to play morse code for character "
 ;;--------------------------------------------
           chr [char!]  ;; character A .. Z
      ][
      sleep 500           ;; short break so u can read the character first
      ind:   to-integer chr - 64 ;; calculate index for morse array
      foreach sym mc/:ind [     ;; foreach symbol of code for character ...
        prin sym                  ;; prin(t) "." or "-"
        either sym = #"." [     ;; short beep
          beep FREQ DIT
      ][
        beep FREQ 3 * DIT     ;; or long beep = 3 x short
      ]
      sleep DIT                   ;; short break after each character
    ]
]
 ;;----------------------------------------------
 morse-text: func ["extract valid characters from sentence"
 ;;----------------------------------------------
        msg [string!]
][
 foreach chr uppercase msg [
    prin  chr prin " "    ;; print character
  ;; valid character  A-Z ?
   either   (chr >= #"A") and (chr <= #"Z") [
      send-code chr
    ] [          ;; ... "else" word gap or unknown
      sleep 6 * DIT   ;; pause after word
    ]
    prin newline    ;; equal to :  print """ ,( prin prints without crlf )
  ]
  sleep 6 * DIT  ;; pause after sentence
 ]
 ;;----------------------------------

morse-text "rosetta code"
morse-text "hello world"


//!
//! morse_code/src/main.rs
//!
//! Michael G. Cummings
//! 2019-08-26
//!
//! Since Rust doesn't have build-in audio support text output is used.
//!

use std::process;
use structopt::StructOpt;
use morse_code::{Config, Opt, run};

/// Core of the command-line binary.
///
/// By default expects input from stdin and outputs resulting morse code to stdout, but can also
/// read and/or write to files.
/// Use `morse_code --help` for more information about options.
fn main() {
    let opts = Opt::from_args();
    let mut config = Config::new(opts).unwrap_or_else(|err| {
        eprintln!("Problem parsing arguments: {}", err);
        process::exit(1);
    });
    if let Err(err) = run(&mut config) {
        eprintln!("Application error: {}", err);
        process::exit(2);
    }
}


# This uses the GUI-free part of the Snack library
package require sound

# A simple pause while running the event loop, in terms of basic time units
proc pause n {
    global t
    after [expr {$t * $n}] set ok 1
    vwait ok
}
# Generate using a sine-wave filter
proc beep n {
    global frequency
    set f [snack::filter generator $frequency 30000 0.0 sine -1]
    set s [snack::sound -rate 22050]
    $s play -filter $f
    pause $n
    $s stop
    $s destroy
    $f destroy
    pause 1
}
# The dits and the dahs are just beeps of different lengths
interp alias {} dit {} beep 1
interp alias {} dah {} beep 3

set MORSE_CODE {
    "!" "---."	 "\"" ".-..-."	"$" "...-..-"	"'" ".----."
    "(" "-.--."	 ")" "-.--.-"	"+" ".-.-."	"," "--..--"
    "-" "-....-" "." ".-.-.-"	"/" "-..-."
    ":" "---..." ";" "-.-.-."	"=" "-...-"	"?" "..--.."
    "@" ".--.-." "[" "-.--."	"]" "-.--.-"	"_" "..--.-"
    "0" "-----"	 "1" ".----"	"2" "..---"	"3" "...--"
    "4" "....-"	 "5" "....."	"6" "-...."	"7" "--..."
    "8" "---.."	 "9" "----."
    "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" "--.."
}

# The code to translate text to morse code and play it
proc morse {str wpm} {
    global t MORSE_CODE
    set t [expr {1200 / $wpm}]
    # Backslash and space are special cases in various ways
    set map {"\\" {} " " {[pause 4]}}
    # Append each item in the code to the map, with an inter-letter pause after
    foreach {from to} $MORSE_CODE {lappend map $from "$to\[pause 3\]"}
    # Convert to dots and dashes
    set s [string map $map [string toupper $str]]
    # Play the dots and dashes by substituting commands for them
    subst [string map {"." [dit] "-" [dah]} $s]
    return
}

# We'll play at a fairly high pitch
set frequency 700

morse "Morse code with Tcl and Snack." 20


decl ursa.util.sound snd
decl string<> chars
decl string<> morse

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

decl int e f chargap wordgap
# element time in ms. one dot is on for e then off for e
set e 50
# tone frequency in hertz
set f 1280
# time between characters of a word (in units of e)
set chargap 1
# time between words (in units of e)
set wordgap 7

def gap (int n)
	sleep (* n e)
end gap
decl function off
set off gap

def on (int n)
	 snd.beep f (/ (* n e) 1000)
end on

def dot ()
	on 1
	off 1
end dot

def dash ()
	on 3
	off 1
end dash

def bloop (int n)
	snd.beep (/ f 2) (/ (* n e) 1000)
end bloop

def encode_morse (string text)
	decl string<> words
	set words (split (upper (trim text)) " ")
	decl int i j k
	for () (< i (size words)) (inc i)
		for (set j 0) (< j (size words<i>)) (inc j)
			decl int loc
			set loc (locate words<i><j> chars)
			if (= loc -1)
				bloop 3
			else
				for (set k 0) (< k (size morse<loc>)) (inc k)
					if (= morse<loc><k> "-")
						dash
					elif (= morse<loc><k> ".")
						dot
					else
						bloop 3
					end if
				end for
			end if
			gap chargap
		end for
		gap wordgap
	end for
end encode_morse

# --- uncomment this block to output the source of this file as morse
# decl file src
# src.open args<0>
# encode_morse (src.readall)

while true
	out "A string to change into morse: " console
	encode_morse (in string console)
end while


Option Explicit

Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const MORSE_ALPHA As String = ".-,-...,-.-.,-..,.,..-.,--.,....,..,.---,-.-,.-..,--,-.,---,.--.,--.-,.-.,...,-,..-,...-,.--,-..-,-.--,--.."
Private Const MORSE_NUMERIC As String = "-----,.----,..---,...--,....-,.....,-....,--...,---..,----."

Private Const ONE_UNIT As Integer = 100

Private Const BEEP_DOT As Integer = ONE_UNIT
Private Const BEEP_DASH As Integer = 3 * ONE_UNIT
Private Const BEEP_OTHER As Integer = 7 * ONE_UNIT
Private Const DELAY As Integer = ONE_UNIT
Private Const LETTERS_DELAY As Integer = 3 * ONE_UNIT
Private Const SPACE_DELAY As Integer = 7 * ONE_UNIT

Private Const FREQUENCY_CHARS As Integer = 1200
Private Const FREQUENCY_OTHERCHARS As Integer = 400

Sub Main()
Dim p$, temp$
    p = ToMorse("Hel/lo 123 world")
    temp = Replace(p, "+", "")
    Debug.Print Replace(temp, "_", "")
    PlayMorse p
End Sub

Private Function ToMorse(s As String) As String
Dim i&, t$, j&
    s = UCase(s)
    For i = 1 To Len(s)
        j = Asc(Mid(s, i, 1))
        Select Case j
            Case 65 To 90 'alpha
                t = t & Split(MORSE_ALPHA, ",")(j - 65) & "+" ' "+" ==> separate each characters
            Case 48 To 57 'numerics
                t = t & Split(MORSE_NUMERIC, ",")(j - 48) & "+"
            Case 32 'space
                t = t & " " & "+"
            Case Else 'others
                t = t & "_" & "+"
        End Select
    Next i
    ToMorse = t
End Function

Private Sub PlayMorse(s As String)
Dim i&
    For i = 1 To Len(s)
        Select Case Mid(s, i, 1)
            Case ".": Beep FREQUENCY_CHARS, BEEP_DOT
            Case "-": Beep FREQUENCY_CHARS, BEEP_DASH
            Case "_": Beep FREQUENCY_OTHERCHARS, BEEP_OTHER
            Case "+": Sleep LETTERS_DELAY
            Case " ": Sleep SPACE_DELAY
        End Select
        Sleep DELAY
    Next i
End Sub


V stay = 0
V sw = 0

L 1000
   V lst = [1, 0, 0]
   random:shuffle(&lst)
   V ran = random:(3)
   V user = lst[ran]
   lst.pop(ran)

   V huh = 0
   L(i) lst
      I i == 0
         lst.pop(huh)
         L.break
      huh++

   I user == 1
      stay++

   I lst[0] == 1
      sw++

print(‘Stay = ’stay)
print(‘Switch = ’sw)


time:	equ	2Ch		; MS-DOS syscall to get current time
puts:	equ	9		; MS-DOS syscall to print a string
	cpu	8086
	bits	16
	org	100h
section	.text
	;;;	Initialize the RNG with the current time
	mov	ah,time
	int	21h
	mov	di,cx		; RNG state is kept in DI and BP
	mov	bp,dx
	mov	dx,sw		; While switching doors,
	mov	bl,1
	call	simrsl		; run simulations,
	mov	dx,nsw		; While not switching doors,
	xor	bl,bl		; run simulations.
	;;;	Print string in DX, run 65536 simulations (according to BL),
	;;;	then print the amount of cars won.
simrsl:	mov	ah,puts		; Print the string
	int	21h
	xor	cx,cx		; Run 65536 simulations
	call	simul
	mov	ax,si		; Print amount of cars
	mov	bx,number	; String pointer
	mov	cx,10		; Divisor
.dgt:	xor	dx,dx		; Divide AX by ten
	div	cx
	add	dl,'0'		; Add ASCII '0' to the remainder
	dec	bx		; Move string pointer backwards
	mov	[bx],dl		; Store digit in string
	test	ax,ax		; If quotient not zero,
	jnz	.dgt		; calculate next digit.
	mov	dx,bx		; Print string starting at first digit
	mov	ah,puts
	int	21h
	ret
	;;;	Run CX simulations.
	;;;	If BL = 0, don't switch doors, otherwise, always switch
simul:	xor	si,si		; SI is the amount of cars won
.loop:	call	door		; Behind which door is the car?
	xchg	dl,al		; DL = car door
	call	door		; Which door does the contestant choose?
	xchg	ah,al		; AH = contestant door
.monty:	call	door		; Which door does Monty open?
	cmp	al,dl		; It can't be the door with the car,
	je	.monty
	cmp	al,ah		; or the door the contestant picked.
	je	.monty
	test	bl,bl		; Will the contestant switch doors?
	jz	.nosw
	xor	ah,al		; If so, he switches
.nosw:	cmp	ah,dl		; Did he get the car?
	jne	.next
	inc	si		; If so, add a car
.next:	loop	.loop
	ret
	;;;	Generate a pseudorandom byte in AL using "X ABC" method
	;;;	Use it to select a door (1,2,3).
door:	xchg	bx,bp		; Load RNG state into byte-addressable
	xchg	cx,di 		; registers.
.loop:	inc	bl		; X++
	xor	bh,ch		; A ^= C
	xor	bh,bl		; A ^= X
	add	cl,bh		; B += A
	mov	al,cl		; C' = B
	shr	al,1		; C' >>= 1
	add	al,ch		; C' += C
	xor	al,bh		; C' ^= A
	mov	ch,al		; C = C'
	and	al,3		; ...but we only want the last two bits,
	jz	.loop		; and if it was 0, get a new random number.
	xchg	bx,bp		; Restore the registers
	xchg	cx,di
	ret
section	.data
sw:	db	'When switching doors:     $'
nsw:	db	'When not switching doors: $'
	db	'*****'
number:	db	13,10,'$'


-V MAXITER = 151

F minkowski(x) -> Float
   I x > 1 | x < 0
      R floor(x) + minkowski(x - floor(x))

   V p = Int(x)
   V q = 1
   V r = p + 1
   V s = 1
   V d = 1.0
   V y = Float(p)

   L
      d /= 2
      I y + d == y
         L.break

      V m = p + r
      I m < 0 | p < 0
         L.break

      V n = q + s
      I n < 0
         L.break

      I x < Float(m) / n
         r = m
         s = n
      E
         y += d
         p = m
         q = n

   R y + d

F minkowski_inv(=x) -> Float
   I x > 1 | x < 0
      R floor(x) + minkowski_inv(x - floor(x))

   I x == 1 | x == 0
      R x

   V cont_frac = [0]
   V current = 0
   V count = 1
   V i = 0

   L
      x *= 2

      I current == 0
         I x < 1
            count++
         E
            cont_frac.append(0)
            cont_frac[i] = count

            i++
            count = 1
            current = 1
            x--
      E
         I x > 1
            count++
            x--
         E
            cont_frac.append(0)
            cont_frac[i] = count

            i++
            count = 1
            current = 0

      I x == floor(x)
         cont_frac[i] = count
         L.break

      I i == :MAXITER
         L.break

   V ret = 1.0 / cont_frac[i]
   L(j) (i-1 .. 0).step(-1)
      ret = cont_frac[j] + 1.0 / ret

   R 1.0 / ret

print(‘#2.16 #2.16’.format(minkowski(0.5 * (1 + sqrt(5))), 5.0 / 3.0))
print(‘#2.16 #2.16’.format(minkowski_inv(-5.0 / 9.0), (sqrt(13) - 7) / 6))
print(‘#2.16 #2.16’.format(minkowski(minkowski_inv(0.718281828)), minkowski_inv(minkowski(0.1213141516171819))))


package {
	import flash.display.Sprite;

	public class MontyHall extends Sprite
	{
		public function MontyHall()
		{
			var iterations:int = 30000;
			var switchWins:int = 0;
			var stayWins:int = 0;

			for (var i:int = 0; i < iterations; i++)
			{
				var doors:Array = [0, 0, 0];
				doors[Math.floor(Math.random() * 3)] = 1;
				var choice:int = Math.floor(Math.random() * 3);
				var shown:int;

				do
				{
					shown = Math.floor(Math.random() * 3);
				} while (doors[shown] == 1 || shown == choice);

				stayWins += doors[choice];
				switchWins += doors[3 - choice - shown];
			}

			trace("Switching wins " + switchWins + " times. (" + (switchWins / iterations) * 100 + "%)");
			trace("Staying wins " + stayWins + " times. (" + (stayWins / iterations) * 100 + "%)");
		}
	}
}


-- Monty Hall Game

with Ada.Text_Io; use Ada.Text_Io;
with Ada.Float_Text_Io; use Ada.Float_Text_Io;
with ada.Numerics.Discrete_Random;

procedure Monty_Stats is
   Num_Iterations : Positive := 100000;
   type Action_Type is (Stay, Switch);
   type Prize_Type is (Goat, Pig, Car);
   type Door_Index is range 1..3;
   package Random_Prize is new Ada.Numerics.Discrete_Random(Door_Index);
   use Random_Prize;
   Seed : Generator;
   Doors : array(Door_Index) of Prize_Type;

   procedure Set_Prizes is
      Prize_Index : Door_Index;
      Booby_Prize : Prize_Type := Goat;
   begin
      Reset(Seed);
      Prize_Index := Random(Seed);
      Doors(Prize_Index) := Car;
      for I in Doors'range loop
         if I /= Prize_Index then
            Doors(I) := Booby_Prize;
            Booby_Prize := Prize_Type'Succ(Booby_Prize);
         end if;
      end loop;
   end Set_Prizes;

   function Play(Action : Action_Type) return Prize_Type is
      Chosen : Door_Index := Random(Seed);
      Monty : Door_Index;
   begin
      Set_Prizes;
      for I in Doors'range loop
         if I /= Chosen and Doors(I) /= Car then
            Monty := I;
         end if;
      end loop;
      if Action = Switch then
         for I in Doors'range loop
            if I /= Monty and I /= Chosen then
               Chosen := I;
               exit;
            end if;
         end loop;
      end if;
      return Doors(Chosen);
   end Play;
   Winners : Natural;
   Pct : Float;
begin
   Winners := 0;
   for I in 1..Num_Iterations loop
      if Play(Stay) = Car then
         Winners := Winners + 1;
      end if;
   end loop;
   Put("Stay : count" & Natural'Image(Winners) & " = ");
   Pct := Float(Winners * 100) / Float(Num_Iterations);
   Put(Item => Pct, Aft => 2, Exp => 0);
   Put_Line("%");
   Winners := 0;
   for I in 1..Num_Iterations loop
      if Play(Switch) = Car then
         Winners := Winners + 1;
      end if;
   end loop;
   Put("Switch : count" & Natural'Image(Winners) & " = ");
   Pct := Float(Winners * 100) / Float(Num_Iterations);
   Put(Item => Pct, Aft => 2, Exp => 0);
   Put_Line("%");

end Monty_Stats;


USING: formatting kernel make math math.constants
math.continued-fractions math.functions math.parser
math.statistics sequences sequences.extras splitting.monotonic
vectors ;

CONSTANT: max-iter 151

: >continued-fraction ( x -- seq )
    0 swap 1vector
    [ dup last integer? pick max-iter > or ]
    [ dup next-approx [ 1 + ] dip ] until nip
    dup last integer? [ but-last-slice ] unless ;

: ? ( x -- y )
    >continued-fraction unclip swap cum-sum
    [ max-iter < ] take-while
    [ even? 1 -1 kernel:? swap 2^ / ] map-index
    sum 2 * + >float ;

: (float>bin) ( x -- y )
    [ dup 0 > ]
    [ 2 * dup >integer # dup 1 >= [ 1 - ] when ] while ;

: float>bin ( x -- n str )
    >float dup >integer [ - ] keep swap abs
    [ 0 # (float>bin) ] "" make nip ;

: ?⁻¹ ( x -- y )
    dup float>bin [ = ] monotonic-split
    [ length ] map swap prefix >ratio swap copysign ;

: compare ( x y -- ) "%-25u%-25u\n" printf ;

phi ? 5 3 /f compare
-5/9 ?⁻¹ 13 sqrt 7 - 6 /f compare
0.718281828 ?⁻¹ ? 0.1213141516171819 ? ?⁻¹ compare


#define MAXITER 151

function minkowski( x as double ) as double
    if x>1 or x<0 then return int(x)+minkowski(x-int(x))
    dim as ulongint p = int(x)
    dim as ulongint q = 1, r = p + 1, s = 1, m, n
    dim as double d = 1, y = p
    while true
        d = d / 2.0
        if y + d = y then exit while
        m = p + r
        if m < 0 or p < 0 then exit while
        n = q + s
        if n < 0 then exit while
        if x < cast(double,m) / n then
            r = m
            s = n
        else
            y = y + d
            p = m
            q = n
        end if
    wend
    return y + d
end function

function minkowski_inv( byval x as double ) as double
    if x>1 or x<0 then return int(x)+minkowski_inv(x-int(x))
    if x=1 or x=0 then return x
    redim as uinteger contfrac(0 to 0)
    dim as uinteger curr=0, count=1, i = 0
    do
        x *= 2
        if curr = 0 then
            if x<1 then
                count += 1
            else
                i += 1
                redim preserve contfrac(0 to i)
                contfrac(i-1)=count
                count = 1
                curr = 1
                x=x-1
            endif
        else
            if x>1 then
                count += 1
                x=x-1
            else
                i += 1
                redim preserve contfrac(0 to i)
                contfrac(i-1)=count
                count = 1
                curr = 0
            endif
        end if
        if x = int(x) then
            contfrac(i)=count
            exit do
        end if
    loop until i = MAXITER
    dim as double ret = 1.0/contfrac(i)
    for j as integer = i-1 to 0 step -1
        ret = contfrac(j) + 1.0/ret
    next j
    return 1./ret
end function

print minkowski( 0.5*(1+sqr(5)) ), 5./3
print minkowski_inv( -5./9 ), (sqr(13)-7)/6
print minkowski(minkowski_inv(0.718281828)), minkowski_inv(minkowski(0.1213141516171819))


INT trials=100 000;

PROC brand = (INT n)INT: 1 + ENTIER (n * random);

PROC percent = (REAL x)STRING: fixed(100.0*x/trials,0,2)+"%";

main:
(
  INT prize, choice, show, not shown, new choice;
  INT stay winning:=0, change winning:=0, random winning:=0;
  INT doors = 3;
  [doors-1]INT other door;

  TO trials DO
     # put the prize somewhere #
     prize := brand(doors);
     # let the user choose a door #
     choice := brand(doors);
     # let us take a list of unchoosen doors #
     INT k := LWB other door;
     FOR j TO doors DO
        IF j/=choice THEN other door[k] := j; k+:=1 FI
     OD;
     # Monty opens one... #
     IF choice = prize THEN
     # staying the user will win... Monty opens a random port#
       show := other door[ brand(doors - 1) ];
       not shown := other door[ (show+1) MOD (doors - 1 ) + 1]
     ELSE # no random, Monty can open just one door... #
       IF other door[1] = prize THEN
           show := other door[2];
           not shown := other door[1]
       ELSE
           show := other door[1];
           not shown := other door[2]
       FI
     FI;

     # the user randomly choose one of the two closed doors
        (one is his/her previous choice, the second is the
        one not shown ) #
     other door[1] := choice;
     other door[2] := not shown;
     new choice := other door[ brand(doors - 1) ];
     # now let us count if it takes it or not #
     IF choice = prize THEN stay winning+:=1 FI;
     IF not shown = prize THEN change winning+:=1 FI;
     IF new choice = prize THEN random winning+:=1 FI
  OD;

  print(("Staying: ", percent(stay winning), new line ));
  print(("Changing: ", percent(change winning), new line ));
  print(("New random choice: ", percent(random winning), new line ))
)


package main

import (
    "fmt"
    "math"
)

const MAXITER = 151

func minkowski(x float64) float64 {
    if x > 1 || x < 0 {
        return math.Floor(x) + minkowski(x-math.Floor(x))
    }
    p := uint64(x)
    q := uint64(1)
    r := p + 1
    s := uint64(1)
    d := 1.0
    y := float64(p)
    for {
        d = d / 2
        if y+d == y {
            break
        }
        m := p + r
        if m < 0 || p < 0 {
            break
        }
        n := q + s
        if n < 0 {
            break
        }
        if x < float64(m)/float64(n) {
            r = m
            s = n
        } else {
            y = y + d
            p = m
            q = n
        }
    }
    return y + d
}

func minkowskiInv(x float64) float64 {
    if x > 1 || x < 0 {
        return math.Floor(x) + minkowskiInv(x-math.Floor(x))
    }
    if x == 1 || x == 0 {
        return x
    }
    contFrac := []uint32{0}
    curr := uint32(0)
    count := uint32(1)
    i := 0
    for {
        x *= 2
        if curr == 0 {
            if x < 1 {
                count++
            } else {
                i++
                t := contFrac
                contFrac = make([]uint32, i+1)
                copy(contFrac, t)
                contFrac[i-1] = count
                count = 1
                curr = 1
                x--
            }
        } else {
            if x > 1 {
                count++
                x--
            } else {
                i++
                t := contFrac
                contFrac = make([]uint32, i+1)
                copy(contFrac, t)
                contFrac[i-1] = count
                count = 1
                curr = 0
            }
        }
        if x == math.Floor(x) {
            contFrac[i] = count
            break
        }
        if i == MAXITER {
            break
        }
    }
    ret := 1.0 / float64(contFrac[i])
    for j := i - 1; j >= 0; j-- {
        ret = float64(contFrac[j]) + 1.0/ret
    }
    return 1.0 / ret
}

func main() {
    fmt.Printf("%19.16f %19.16f\n", minkowski(0.5*(1+math.Sqrt(5))), 5.0/3.0)
    fmt.Printf("%19.16f %19.16f\n", minkowskiInv(-5.0/9.0), (math.Sqrt(13)-7)/6)
    fmt.Printf("%19.16f %19.16f\n", minkowski(minkowskiInv(0.718281828)),
        minkowskiInv(minkowski(0.1213141516171819)))
}


     ∇ Run runs;doors;i;chosen;cars;goats;swap;stay;ix;prices
[1]   ⍝0: Monthy Hall problem
[2]   ⍝1: http://rosettacode.org/wiki/Monty_Hall_problem
[3]
[4]    (⎕IO ⎕ML)←0 1
[5]    prices←0 0 1               ⍝ 0=Goat, 1=Car
[6]
[7]    ix←⊃,/{3?3}¨⍳runs          ⍝ random indexes of doors (placement of car)
[8]    doors←(runs 3)⍴prices[ix]  ⍝ matrix of doors
[9]    stay←+⌿doors[;?3]          ⍝ chose randomly one door - is it a car?
[10]   swap←runs-stay             ⍝ If not, then the other one is!
[11]
[12]   ⎕←'Swap: ',(2⍕100×(swap÷runs)),'% it''s a car'
[13]   ⎕←'Stay: ',(2⍕100×(stay÷runs)),'% it''s a car'
     ∇


stay: 0
swit: 0

loop 1..1000 'i [
    lst: shuffle new [1 0 0]
    rand: random 0 2
    user: lst\[rand]
    remove 'lst rand

    huh: 0
    loop lst 'i [
        if zero? i [
            remove 'lst huh
            break
        ]
        huh: huh + 1
    ]

    if user=1 -> stay: stay+1
    if and? [0 < size lst] [1 = first lst] -> swit: swit+1
]

print ["Stay:" stay]
print ["Switch:" swit]


import Data.Tree
import Data.Ratio
import Data.List

intervalTree :: (a -> a -> a) -> (a, a) -> Tree a
intervalTree node = unfoldTree $
  \(a, b) -> let m = node a b in (m, [(a,m), (m,b)])

Node a _ ==> Node b [] = const b
Node a [] ==> Node b _ = const b
Node a [l1, r1] ==> Node b [l2, r2] =
  \x -> case x `compare` a of
          LT -> (l1 ==> l2) x
          EQ -> b
          GT -> (r1 ==> r2) x

mirror :: Num a => Tree a -> Tree a
mirror t = Node 0 [reflect (negate <$> t), t]
  where
    reflect (Node a [l,r]) = Node a [reflect r, reflect l]

------------------------------------------------------------

sternBrocot :: Tree Rational
sternBrocot = toRatio <$> intervalTree mediant ((0,1), (1,0))
  where
    mediant (p, q) (r, s) = (p + r, q + s)

toRatio (p, q) = p % q

minkowski :: Tree Rational
minkowski = toRatio <$> intervalTree mean ((0,1), (1,0))

mean (p, q) (1, 0) = (p+1, q)
mean (p, q) (r, s) = (p*s + q*r, 2*q*s)

questionMark, invQuestionMark :: Rational -> Rational
questionMark    = mirror sternBrocot ==> mirror minkowski
invQuestionMark = mirror minkowski ==> mirror sternBrocot

------------------------------------------------------------
-- Floating point trees and functions

sternBrocotF :: Tree Double
sternBrocotF = mirror $ fromRational <$> sternBrocot

minkowskiF :: Tree Double
minkowskiF = mirror $ intervalTree mean (0, 1/0)
  where
    mean a b | isInfinite b = a + 1
             | otherwise = (a + b) / 2

questionMarkF, invQuestionMarkF :: Double -> Double
questionMarkF = sternBrocotF ==> minkowskiF
invQuestionMarkF = minkowskiF ==> sternBrocotF


ITERCOUNT=: 52

minkowski=: {{
  f=. 1|y
  node=. *i.2 2 NB. node of Stern-Brocot tree
  B=. ''
  for. i.ITERCOUNT do.
    B=. B, b=. f>:%/t=. +/node
    node=. t (1-b)} node
  end.
  (<.y)+B+/ .*2^-1+i.ITERCOUNT
}}

invmink=: {{
  f=. 1|y
  cf=. i.0
  cur=. 0 NB. 1 if generating "top" side of cf
  cnt=. 1 NB. proposed continued fraction element
  for. i.ITERCOUNT do.
    if. f=<. f do.
      cf=. cf,%cnt break.
    end.
    f=. f*2
    b=. 1 >`<@.cur f
    cf=. cf,(-.b)#cnt
    cnt=. 1+b*cnt
    cur=. cur=b
    f=. f-cur
  end.
  (+%)/(<.y),cf
}}


#SingleInstance, Force
Iterations = 1000
Loop, %Iterations%
{
   If Monty_Hall(1)
      Correct_Change++
   Else
      Incorrect_Change++
   If Monty_Hall(2)
      Correct_Random++
   Else
      Incorrect_Random++
   If Monty_Hall(3)
      Correct_Stay++
   Else
      Incorrect_Stay++
}
Percent_Change := round(Correct_Change / Iterations * 100)
Percent_Stay := round(Correct_Stay / Iterations * 100)
Percent_Random := round(Correct_Random / Iterations * 100)

MsgBox,, Monty Hall Problem, These are the results:`r`n`r`nWhen I changed my guess, I got %Correct_Change% of %Iterations% (that's %Incorrect_Change% incorrect). That's %Percent_Change%`% correct.`r`n`r`nWhen I randomly changed my guess, I got %Correct_Random% of %Iterations% (that's %Incorrect_Random% incorrect). That's %Percent_Random%`% correct.`r`n`r`nWhen I stayed with my first guess, I got %Correct_Stay% of %Iterations% (that's %Incorrect_Stay% incorrect). That's %Percent_Stay%`% correct.
ExitApp

Monty_Hall(Mode) ;Mode is 1 for change, 2 for random, or 3 for stay
{
	Random, guess, 1, 3
	Random, actual, 1, 3
	Random, rand, 1, 2

	show := guess = actual ? guess = 3 ? guess - rand : guess = 1 ? guess+rand : guess + 2*rand - 3 : 6 - guess - actual
	Mode := Mode = 2 ? 2*rand - 1: Mode
	Return, Mode = 1 ?  6 - guess - show = actual : guess = actual
}


with Ada.Text_IO, Ada.Command_Line, Crypto.Types.Big_Numbers;

procedure Mod_Exp is

   A: String :=
     "2988348162058574136915891421498819466320163312926952423791023078876139";
   B: String :=
     "2351399303373464486466122544523690094744975233415544072992656881240319";

   D: constant Positive := Positive'Max(Positive'Max(A'Length, B'Length), 40);
     -- the number of decimals to store A, B, and result
   Bits: constant Positive := (34*D)/10;
     -- (slightly more than) the number of bits to store A, B, and result
   package LN is new Crypto.Types.Big_Numbers (Bits + (32 - Bits mod 32));
     -- the actual number of bits has to be a multiple of 32
   use type LN.Big_Unsigned;

   function "+"(S: String) return LN.Big_Unsigned
     renames LN.Utils.To_Big_Unsigned;

   M: LN.Big_Unsigned := (+"10") ** (+"40");

begin
   Ada.Text_IO.Put("A**B (mod 10**40) = ");
   Ada.Text_IO.Put_Line(LN.Utils.To_String(LN.Mod_Utils.Pow((+A), (+B), M)));
end Mod_Exp;


BEGIN
   PR precision=1000 PR
   MODE LLI = LONG LONG INT;	CO For brevity CO
   PROC mod power = (LLI base, exponent, modulus) LLI :
   BEGIN
      LLI result := 1, b := base, e := exponent;
      IF exponent < 0
      THEN
	 put (stand error, (("Negative exponent", exponent, newline)))
      ELSE
	 WHILE e > 0
	 DO
	    (ODD e | result := (result * b) MOD modulus);
	    e OVERAB 2; b := (b * b) MOD modulus
	 OD
      FI;
      result
   END;
   LLI a = 2988348162058574136915891421498819466320163312926952423791023078876139;
   LLI b = 2351399303373464486466122544523690094744975233415544072992656881240319;
   LLI m = 10000000000000000000000000000000000000000;
   printf (($"Last 40 digits = ", 40dl$, mod power (a, b, m)))
END


function minkowski(x)
    p = Int(floor(x))
    (x > 1 || x < 0) && return p + minkowski(x)
    q, r, s, m, n = 1, p + 1, 1, 0, 0
    d, y = 1.0, Float64(p)
    while true
        d /= 2.0
        y + d == y && break
        m = p + r
        (m < 0 || p < 0) && break
        n = q + s
        n < 0 && break
        if x < (m / n)
            r, s = m, n
        else
            y, p, q = y + d, m, n
        end
    end
    return y + d
end

function minkowski_inv(x, maxiter=151)
    p = Int(floor(x))
    (x > 1 || x < 0) && return p + minkowski_inv(x - p, maxiter)
    (x == 1 || x == 0) && return x
    contfrac = [0]
    curr, coun, i = 0, 1, 0
    while i < maxiter
        x *= 2
        if curr == 0
            if x < 1
                coun += 1
            else
                i += 1
                push!(contfrac, 0)
                contfrac[i] = coun
                coun = 1
                curr = 1
                x -= 1
            end
        else
            if x > 1
                coun += 1
                x -= 1
            else
                i += 1
                push!(contfrac, 0)
                contfrac[i] = coun
                coun = 1
                curr = 0
            end
        end
        if x == Int(floor(x))
            contfrac[i + 1] = coun
            break
        end
    end
    ret = 1.0 / contfrac[i + 1]
    for j in i:-1:1
        ret = contfrac[j] + 1.0 / ret
    end
    return 1.0 / ret
end

println(" ", minkowski((1 + sqrt(5)) / 2), "   ", 5 / 3)
println(minkowski_inv(-5/9), "   ", (sqrt(13) - 7) / 6)
println(" ", minkowski(minkowski_inv(0.718281828)), "   ",
    minkowski_inv(minkowski(0.1213141516171819)))


ClearAll[InverseMinkowskiQuestionMark]
InverseMinkowskiQuestionMark[val_] := Module[{x}, (x /. FindRoot[MinkowskiQuestionMark[x] == val, {x, Floor[val], Ceiling[val]}])]
MinkowskiQuestionMark[GoldenRatio]
InverseMinkowskiQuestionMark[-5/9] // RootApproximant
MinkowskiQuestionMark[InverseMinkowskiQuestionMark[0.1213141516171819]]
InverseMinkowskiQuestionMark[MinkowskiQuestionMark[0.1213141516171819]]


import math, strformat

const MaxIter = 151

func minkowski(x: float): float =

  if x notin 0.0..1.0:
    return floor(x) + minkowski(x - floor(x))

  var
    p = x.uint64
    r = p + 1
    q, s = 1u64
    d = 1.0
    y = p.float

  while true:
    d /= 2
    if y + d == y: break
    let m = p + r
    if m < 0 or p < 0: break
    let n = q + s
    if n < 0: break
    if x < m.float / n.float:
      r = m
      s = n
    else:
      y += d
      p = m
      q = n

  result = y + d

func minkowskiInv(x: float): float =

  if x notin 0.0..1.0:
    return floor(x) + minkowskiInv(x - floor(x))
  if x == 1 or x == 0:
    return x

  var
    contFrac: seq[uint32]
    curr = 0u32
    count = 1u32
    i = 0
    x = x

  while true:
    x *= 2
    if curr == 0:
      if x < 1:
        inc count
      else:
        inc i
        contFrac.setLen(i + 1)
        contFrac[i - 1] = count
        count = 1
        curr = 1
        x -= 1
    else:
      if x > 1:
        inc count
        x -= 1
      else:
        inc i
        contFrac.setLen(i + 1)
        contFrac[i - 1] = count
        count = 1
        curr = 0
    if x == floor(x):
      contFrac[i] = count
      break
    if i == MaxIter:
      break

  var ret = 1 / contFrac[i].float
  for j in countdown(i - 1, 0):
    ret = contFrac[j].float + 1 / ret
  result = 1 / ret

echo &"{minkowski(0.5*(1+sqrt(5.0))):19.16f}, {5/3:19.16f}"
echo &"{minkowskiInv(-5/9):19.16f}, {(sqrt(13.0)-7)/6:19.16f}"
echo &"{minkowski(minkowskiInv(0.718281828)):19.16f}, " &
     &"{minkowskiInv(minkowski(0.1213141516171819)):19.16f}"


use strict;
use warnings;
use feature 'say';
use POSIX qw(floor);

my $MAXITER = 50;

sub minkowski {
    my($x) = @_;

    return floor($x) + minkowski( $x - floor($x) ) if $x > 1 || $x < 0 ;

    my $y = my $p = floor($x);
    my ($q,$s,$d) = (1,1,1);
    my $r = $p + 1;

    while () {
        last if ( $y + ($d /= 2)  == $y ) or
                ( my $m = $p + $r) <  0   or
                ( my $n = $q + $s) <  0;
        $x < $m/$n ? ($r,$s) = ($m, $n) : ($y += $d and ($p,$q) = ($m, $n) );
    }
    return $y + $d
}

sub minkowskiInv {
    my($x) = @_;

    return floor($x) + minkowskiInv($x - floor($x)) if $x > 1 || $x < 0;
    return $x if $x == 1 || $x == 0 ;

    my @contFrac = 0;
    my $i = my $curr = 0 ; my $count = 1;

    while () {
        $x *= 2;
        if ($curr == 0) {
            if ($x < 1) {
                $count++
            } else {
                $i++;
                push @contFrac, 0;
                $contFrac[$i-1] = $count;
                ($count,$curr) = (1,1);
                $x--;
            }
        } else {
            if ($x > 1) {
                $count++;
                $x--;
            } else {
                $i++;
                push @contFrac, 0;
                @contFrac[$i-1] = $count;
                ($count,$curr) = (1,0);
            }
        }
        if ($x == floor($x)) { @contFrac[$i] = $count; last }
        last if $i == $MAXITER;
    }
    my $ret = 1 / $contFrac[$i];
    for (my $j = $i - 1; $j >= 0; $j--) { $ret = $contFrac[$j] + 1/$ret }
    return 1 / $ret
}

printf "%19.16f %19.16f\n", minkowski(0.5*(1 + sqrt(5))), 5/3;
printf "%19.16f %19.16f\n", minkowskiInv(-5/9), (sqrt(13)-7)/6;
printf "%19.16f %19.16f\n", minkowski(minkowskiInv(0.718281828)), minkowskiInv(minkowski(0.1213141516171819));


#!/bin/gawk -f

# Monty Hall problem

BEGIN {
	srand()
	doors = 3
	iterations = 10000
	# Behind a door:
	EMPTY = "empty"; PRIZE = "prize"
	# Algorithm used
  KEEP = "keep"; SWITCH="switch"; RAND="random";
  #
}
function monty_hall( choice, algorithm ) {
  # Set up doors
  for ( i=0; i<doors; i++ ) {
		door[i] = EMPTY
	}
  # One door with prize
	door[int(rand()*doors)] = PRIZE

  chosen = door[choice]
  del door[choice]

  #if you didn't choose the prize first time around then
  # that will be the alternative
	alternative = (chosen == PRIZE) ? EMPTY : PRIZE

	if( algorithm == KEEP) {
		return chosen
	}
	if( algorithm == SWITCH) {
		return alternative
	}
	return rand() <0.5 ? chosen : alternative
}

function simulate(algo){
	prizecount = 0
	for(j=0; j< iterations; j++){
		if( monty_hall( int(rand()*doors), algo) == PRIZE) {
			prizecount ++
		}
	}
	printf "  Algorithm %7s: prize count = %i, = %6.2f%%\n", \
		algo, prizecount,prizecount*100/iterations
}

BEGIN {
	print "\nMonty Hall problem simulation:"
	print doors, "doors,", iterations, "iterations.\n"
	simulate(KEEP)
	simulate(SWITCH)
	simulate(RAND)

}


RANDOMIZE TIMER
DIM doors(3) '0 is a goat, 1 is a car
CLS
switchWins = 0
stayWins = 0
FOR plays = 0 TO 32767
	winner = INT(RND * 3) + 1
	doors(winner) = 1'put a winner in a random door
	choice = INT(RND * 3) + 1'pick a door, any door
	DO
		shown = INT(RND * 3) + 1
	'don't show the winner or the choice
	LOOP WHILE doors(shown) = 1 OR shown = choice
	stayWins = stayWins + doors(choice) 'if you won by staying, count it
	switchWins = switchWins + doors(3 - choice - shown) 'could have switched to win
	doors(winner) = 0 'clear the doors for the next test
NEXT plays
PRINT "Switching wins"; switchWins; "times."
PRINT "Staying wins"; stayWins; "times."


#NoEnv
#SingleInstance, Force
SetBatchLines, -1
#Include mpl.ahk

  MP_SET(base, "2988348162058574136915891421498819466320163312926952423791023078876139")
, MP_SET(exponent, "2351399303373464486466122544523690094744975233415544072992656881240319")
, MP_SET(modulus, "10000000000000000000000000000000000000000")

, NumGet(exponent,0,"Int") = -1 ? return : ""
, MP_SET(result, "1")
, MP_SET(TWO, "2")
while !MP_IS0(exponent)
	MP_DIV(q, r, exponent, TWO)
	, (MP_DEC(r) = 1
		? (MP_MUL(temp, result, base)
		, MP_DIV(q, result, temp, modulus))
		: "")
	, MP_DIV(q, r, exponent, TWO)
	, MP_CPY(exponent, q)
	, MP_CPY(base1, base)
	, MP_MUL(base2, base1, base)
	, MP_DIV(q, base, base2, modulus)

msgbox % MP_DEC(result)
Return


with javascript_semantics
constant MAXITER = 151

function minkowski(atom x)
    atom p = floor(x)
    if x>1 or x<0 then return p+minkowski(x-p) end if
    atom q = 1, r = p + 1, s = 1, m, n, d = 1, y = p
    while true do
        d = d/2
        if y + d = y then exit end if
        m = p + r
        if m < 0 or p < 0 then exit end if
        n = q + s
        if n < 0 then exit end if
        if x < m/n then
            r = m
            s = n
        else
            y = y + d
            p = m
            q = n
        end if
    end while
    return y + d
end function

function minkowski_inv(atom x)
    if x>1 or x<0 then return floor(x)+minkowski_inv(x-floor(x)) end if
    if x=1 or x=0 then return x end if
    sequence contfrac = {}
    integer curr = 0, count = 1
    while true do
        x *= 2
        if curr = 0 then
            if x<1 then
                count += 1
            else
                contfrac &= count
                count = 1
                curr = 1
                x -= 1
            end if
        else
            if x>1 then
                count += 1
                x -= 1
            else
                contfrac &= count
                count = 1
                curr = 0
            end if
        end if
        if x = floor(x) then
            contfrac &= count
            exit
        end if
        if length(contfrac)=MAXITER then exit end if
    end while
    atom ret = 1/contfrac[$]
    for i = length(contfrac)-1 to 1 by -1 do
        ret = contfrac[i] + 1.0/ret
    end for
    return 1/ret
end function

printf(1,"%20.16f %20.16f\n",{minkowski(0.5*(1+sqrt(5))), 5/3})
printf(1,"%20.16f %20.16f\n",{minkowski_inv(-5/9), (sqrt(13)-7)/6})
printf(1,"%20.16f %20.16f\n",{minkowski(minkowski_inv(0.718281828)),
                              minkowski_inv(minkowski(0.1213141516171819))})


      total% = 10000
      FOR trial% = 1 TO total%
        prize_door% = RND(3) : REM. The prize is behind this door
        guess_door% = RND(3) : REM. The contestant guesses this door
        IF prize_door% = guess_door% THEN
          REM. The contestant guessed right, reveal either of the others
          reveal_door% = RND(2)
          IF prize_door% = 1 reveal_door% += 1
          IF prize_door% = 2 AND reveal_door% = 2 reveal_door% = 3
        ELSE
          REM. The contestant guessed wrong, so reveal the non-prize door
          reveal_door% = prize_door% EOR guess_door%
        ENDIF
        stick_door% = guess_door% : REM. The sticker doesn't change his mind
        swap_door% = guess_door% EOR reveal_door% : REM. but the swapper does
        IF stick_door% = prize_door% sticker% += 1
        IF swap_door% = prize_door% swapper% += 1
      NEXT trial%
      PRINT "After a total of ";total%;" trials,"
      PRINT "The 'sticker' won ";sticker%;" times (";INT(sticker%/total%*100);"%)"
      PRINT "The 'swapper' won ";swapper%;" times (";INT(swapper%/total%*100);"%)"


//Evidence of the Monty Hall solution.

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

#define GAMES 3000000

int main(void){
    unsigned i, j, k, choice, winsbyswitch=0, door[3];

    srand(time(NULL));                                                          //initialize random seed.
    for(i=0; i<GAMES; i++){
        door[0] = (!(rand()%2)) ? 1: 0;                                         //give door 1 either a car or a goat randomly.
        if(door[0]) door[1]=door[2]=0;                                          //if 1st door has car, give other doors goats.
        else{ door[1] = (!(rand()%2)) ? 1: 0; door[2] = (!door[1]) ? 1: 0; }    //else, give 2nd door car or goat, give 3rd door what's left.
        choice = rand()%3;                                                      //choose a random door.

        //if the next door has a goat, and the following door has a car, or vice versa, you'd win if you switch.
        if(((!(door[((choice+1)%3)])) && (door[((choice+2)%3)])) || (!(door[((choice+2)%3)]) && (door[((choice+1)%3)]))) winsbyswitch++;
    }
    printf("\nAfter %u games, I won %u by switching.  That is %f%%. ", GAMES, winsbyswitch, (float)winsbyswitch*100.0/(float)i);
}


#include <iostream>
#include <boost/multiprecision/cpp_int.hpp>
#include <boost/multiprecision/integer.hpp>

int main() {
    using boost::multiprecision::cpp_int;
    using boost::multiprecision::pow;
    using boost::multiprecision::powm;
    cpp_int a("2988348162058574136915891421498819466320163312926952423791023078876139");
    cpp_int b("2351399303373464486466122544523690094744975233415544072992656881240319");
    std::cout << powm(a, b, pow(cpp_int(10), 40)) << '\n';
    return 0;
}


(defn powerMod "modular exponentiation" [b e m]
  (defn m* [p q] (mod (* p q) m))
  (loop [b b, e e, x 1]
    (if (zero? e) x
      (if (even? e) (recur (m* b b) (/ e 2) x)
        (recur (m* b b) (quot e 2) (m* b x))))))


import math

MAXITER = 151

def minkowski(x):
    if x > 1 or x < 0:
        return math.floor(x) + minkowski(x - math.floor(x))

    p = int(x)
    q = 1
    r = p + 1
    s = 1
    d = 1.0
    y = float(p)

    while True:
        d /= 2
        if y + d == y:
            break

        m = p + r
        if m < 0 or p < 0:
            break

        n = q + s
        if n < 0:
            break

        if x < m / n:
            r = m
            s = n
        else:
            y += d
            p = m
            q = n

    return y + d

def minkowski_inv(x):
    if x > 1 or x < 0:
        return math.floor(x) + minkowski_inv(x - math.floor(x))

    if x == 1 or x == 0:
        return x

    cont_frac = [0]
    current = 0
    count = 1
    i = 0

    while True:
        x *= 2

        if current == 0:
            if x < 1:
                count += 1
            else:
                cont_frac.append(0)
                cont_frac[i] = count

                i += 1
                count = 1
                current = 1
                x -= 1
        else:
            if x > 1:
                count += 1
                x -= 1
            else:
                cont_frac.append(0)
                cont_frac[i] = count

                i += 1
                count = 1
                current = 0

        if x == math.floor(x):
            cont_frac[i] = count
            break

        if i == MAXITER:
            break

    ret = 1.0 / cont_frac[i]
    for j in range(i - 1, -1, -1):
        ret = cont_frac[j] + 1.0 / ret

    return 1.0 / ret

if __name__ == "__main__":
    print(
        "{:19.16f} {:19.16f}".format(
            minkowski(0.5 * (1 + math.sqrt(5))),
            5.0 / 3.0,
        )
    )

    print(
        "{:19.16f} {:19.16f}".format(
            minkowski_inv(-5.0 / 9.0),
            (math.sqrt(13) - 7) / 6,
        )
    )

    print(
        "{:19.16f} {:19.16f}".format(
            minkowski(minkowski_inv(0.718281828)),
            minkowski_inv(minkowski(0.1213141516171819)),
        )
    )


using System;

class Program
{
    static void Main(string[] args)
    {
        int switchWins = 0;
        int stayWins = 0;

        Random gen = new Random();

        for(int plays = 0; plays < 1000000; plays++ )
        {
            int[] doors = {0,0,0};//0 is a goat, 1 is a car

            var winner = gen.Next(3);
            doors[winner] = 1; //put a winner in a random door

	    int choice = gen.Next(3); //pick a door, any door
	    int shown; //the shown door
	    do
            {
	        shown = gen.Next(3);
	    }
            while (doors[shown] == 1 || shown == choice); //don't show the winner or the choice

	    stayWins += doors[choice]; //if you won by staying, count it

            //the switched (last remaining) door is (3 - choice - shown), because 0+1+2=3
            switchWins += doors[3 - choice - shown];
        }

        Console.Out.WriteLine("Staying wins " + stayWins + " times.");
        Console.Out.WriteLine("Switching wins " + switchWins + " times.");
    }
}


#include <iostream>
#include <cstdlib>
#include <ctime>

int randint(int n)
{
  return (1.0*n*std::rand())/(1.0+RAND_MAX);
}

int other(int doorA, int doorB)
{
  int doorC;
  if (doorA == doorB)
  {
    doorC = randint(2);
    if (doorC >= doorA)
      ++doorC;
  }
  else
  {
    for (doorC = 0; doorC == doorA || doorC == doorB; ++doorC)
    {
      // empty
    }
  }
  return doorC;
}

int check(int games, bool change)
{
  int win_count = 0;
  for (int game = 0; game < games; ++game)
  {
    int const winning_door = randint(3);
    int const original_choice = randint(3);
    int open_door = other(original_choice, winning_door);

    int const selected_door = change?
                                other(open_door, original_choice)
                              : original_choice;

    if (selected_door == winning_door)
      ++win_count;
  }

  return win_count;
}

int main()
{
  std::srand(std::time(0));

  int games = 10000;
  int wins_stay = check(games, false);
  int wins_change = check(games, true);
  std::cout << "staying: " << 100.0*wins_stay/games << "%, changing: " << 100.0*wins_change/games << "%\n";
}


(defun rosetta-mod-expt (base power divisor)
  "Return BASE raised to the POWER, modulo DIVISOR.
  This function is faster than (MOD (EXPT BASE POWER) DIVISOR), but
  only works when POWER is a non-negative integer."
  (setq base (mod base divisor))
  ;; Multiply product with base until power is zero.
  (do ((product 1))
      ((zerop power) product)
    ;; Square base, and divide power by 2, until power becomes odd.
    (do () ((oddp power))
      (setq base (mod (* base base) divisor)
	    power (ash power -1)))
    (setq product (mod (* product base) divisor)
	  power (1- power))))

(let ((a 2988348162058574136915891421498819466320163312926952423791023078876139)
      (b 2351399303373464486466122544523690094744975233415544072992656881240319))
  (format t "~A~%" (rosetta-mod-expt a b (expt 10 40))))


module modular_exponentiation;

private import std.bigint;

BigInt powMod(BigInt base, BigInt exponent, in BigInt modulus)
pure nothrow /*@safe*/ in {
   assert(exponent >= 0);
} body {
    BigInt result = 1;

    while (exponent) {
        if (exponent & 1)
            result = (result * base) % modulus;
        exponent /= 2;
        base = base ^^ 2 % modulus;
    }

    return result;
}

version (modular_exponentiation)
    void main() {
        import std.stdio;

        powMod(BigInt("29883481620585741369158914214988194" ~
                      "66320163312926952423791023078876139"),
               BigInt("235139930337346448646612254452369009" ~
                      "4744975233415544072992656881240319"),
               BigInt(10) ^^ 40).writeln;
    }


# 20201120 Raku programming solution

my \MAXITER = 151;

sub minkowski(\x) {

   return x.floor + minkowski( x - x.floor ) if x > 1 || x < 0 ;

   my $y = my $p = x.floor;
   my ($q,$s,$d) = 1 xx 3;
   my $r = $p + 1;

   loop {
      last if ( $y + ($d /= 2)  == $y )        ||
              ( my $m = $p + $r) <  0 | $p < 0 ||
              ( my $n = $q + $s) <  0           ;
      x < $m/$n ?? ( ($r,$s) = ($m, $n) ) !! ( $y += $d; ($p,$q) = ($m, $n) );
   }
   return $y + $d
}

sub minkowskiInv($x is copy) {

   return $x.floor + minkowskiInv($x - $x.floor) if  $x > 1 || $x < 0 ;

   return $x if $x == 1 || $x == 0 ;

   my @contFrac = 0;
   my $i = my $curr = 0 ; my $count = 1;

   loop {
      $x *= 2;
      if $curr == 0 {
         if $x < 1 {
            $count++
         } else {
            $i++;
            @contFrac.append: 0;
            @contFrac[$i-1] = $count;
            ($count,$curr) = 1,1;
            $x--;
         }
      } else {
         if $x > 1 {
            $count++;
            $x--;
         } else {
            $i++;
            @contFrac.append: 0;
            @contFrac[$i-1] = $count;
            ($count,$curr) = 1,0;
         }
      }
      if $x == $x.floor { @contFrac[$i] = $count ; last }
      last if $i == MAXITER;
    }
    my $ret = 1 / @contFrac[$i];
    loop (my $j = $i - 1; $j ≥ 0; $j--) { $ret = @contFrac[$j] + 1/$ret }
    return 1 / $ret
}

printf "%19.16f %19.16f\n", minkowski(0.5*(1 + 5.sqrt)), 5/3;
printf "%19.16f %19.16f\n", minkowskiInv(-5/9), (13.sqrt-7)/6;
printf "%19.16f %19.16f\n", minkowski(minkowskiInv(0.718281828)),
   minkowskiInv(minkowski(0.1213141516171819))


use Random;

param doors: int = 3;
config const games: int = 1000;

config const maxTasks = 32;
var numTasks = 1;
while( games / numTasks > 1000000 && numTasks < maxTasks ) do numTasks += 1;
const tasks = 1..#numTasks;
const games_per_task = games / numTasks ;
const remaining_games = games % numTasks ;

var wins_by_stay: [tasks] int;

coforall task in tasks {

  var rand = new  RandomStream();

  for game in 1..#games_per_task {
    var player_door =  (rand.getNext() * 1000): int % doors ;
    var winning_door = (rand.getNext() * 1000): int % doors ;
    if player_door == winning_door then
      wins_by_stay[ task ] += 1;
  }

  if task == tasks.last then {
    for game in 1..#remaining_games {
      var player_door =  (rand.getNext() * 1000): int % doors ;
      var winning_door = (rand.getNext() * 1000): int % doors ;
      if player_door == winning_door then
        wins_by_stay[ task ] += 1;
    }
  }

}

var total_by_stay = + reduce wins_by_stay;

var total_by_switch = games - total_by_stay;
var percent_by_stay = ((total_by_stay: real) / games) * 100;
var percent_by_switch = ((total_by_switch: real) / games) * 100;

writeln( "Wins by staying: ", total_by_stay, " or ", percent_by_stay, "%" );
writeln( "Wins by switching: ", total_by_switch, " or ", percent_by_switch, "%" );
if ( total_by_stay > total_by_switch ){
  writeln( "Staying is the superior method." );
} else if( total_by_stay < total_by_switch ){
  writeln( "Switching is the superior method." );
} else {
  writeln( "Both methods are equal." );
}


(ns monty-hall-problem
  (:use [clojure.contrib.seq :only (shuffle)]))

(defn play-game [staying]
  (let [doors (shuffle [:goat :goat :car])
        choice (rand-int 3)
        [a b] (filter #(not= choice %) (range 3))
        alternative (if (= :goat (nth doors a)) b a)]
    (= :car (nth doors (if staying choice alternative)))))

(defn simulate [staying times]
  (let [wins (reduce (fn [counter _] (if (play-game staying) (inc counter) counter))
                     0
                     (range times))]
    (str "wins " wins " times out of " times)))


/*REXX program uses the Minkowski question─mark function to convert a continued fraction*/
numeric digits 40                                /*use enough dec. digits for precision.*/
say fmt( mink(  0.5 * (1+sqrt(5) ) ) )     fmt( 5/3 )
say fmt( minkI(-5/9) )                     fmt( (sqrt(13) - 7)  /  6)
say fmt( mink( minkI(0.718281828) ) )      fmt( mink( minkI(.1213141516171819) ) )
exit 0                                           /*stick a fork in it,  we're all done. */
/*──────────────────────────────────────────────────────────────────────────────────────*/
floor: procedure; parse arg x;    t= trunc(x);     return t   -   (x<0)  *  (x\=t)
fmt:   procedure: parse arg a;    d= digits();     return right( format(a, , d-2, 0), d+5)
/*──────────────────────────────────────────────────────────────────────────────────────*/
mink:  procedure:  parse arg x;   p= x % 1;        if x>1 | x<0  then return p + mink(x-p)
       q= 1;    s= 1;    m= 0;    n= 0;    d= 1;   y= p
       r= p + 1
                    do forever;   d= d * 0.5;      if y+d=y | d=0  then leave   /*d= d÷2*/
                    m= p + r;                      if m<0   | p<0  then leave
                    n= q + s;                      if n<0          then leave
                    if x<m/n      then do;   r= m;       s= n;           end
                                  else do;   y= y + d;   p= m;   q= n;   end
                    end   /*forever*/
       return y + d
/*──────────────────────────────────────────────────────────────────────────────────────*/
minkI: procedure;  parse arg x;  p= floor(x);   if x>1 | x<0  then return p + minkI(x-p)
                                                if x=1 | x=0  then return x
       cur= 0;                limit= 200;       $=               /*limit: max iterations*/
       #= 1                                                      /*#:  is the count.    */
                  do  until #==limit | words($)==limit;                        x= x * 2
                  if cur==0  then if x<1  then      #= # + 1
                                          else do;  $= $ #;  #= 1;   cur= 1;  x= x-1;  end
                             else if x>1  then do;           #= # + 1;        x= x-1;  end
                                          else do;  $= $ #;  #= 1;   cur= 0;           end
                  if x==floor(x)          then do;           $= $ #;  leave;           end
                  end   /*until*/
       z= words($)
       ret= 1 / word($, z)
                               do j=z  for z  by -1;    ret= word($, j)    +    1 / ret
                               end   /*j*/
       return 1 / ret
/*──────────────────────────────────────────────────────────────────────────────────────*/
sqrt: procedure; parse arg x;  if x=0  then return 0;  d=digits();  numeric digits;  h=d+6
      numeric form; m.=9; parse value format(x,2,1,,0) 'E0' with g "E" _ .; g=g *.5'e'_ %2
        do j=0  while h>9;     m.j= h;             h= h % 2 + 1;      end  /*j*/
        do k=j+5  to 0  by -1; numeric digits m.k; g= (g + x/g) * .5; end  /*k*/; return g


       IDENTIFICATION DIVISION.
       PROGRAM-ID. monty-hall.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       78  Num-Games               VALUE 1000000.

       *> These are needed so the values are passed to
       *> get-rand-int correctly.
       01  One                     PIC 9 VALUE 1.
       01  Three                   PIC 9 VALUE 3.

       01  doors-area.
           03  doors               PIC 9 OCCURS 3 TIMES.

       01  choice                  PIC 9.
       01  shown                   PIC 9.
       01  winner                  PIC 9.

       01  switch-wins             PIC 9(7).
       01  stay-wins               PIC 9(7).

       01  stay-wins-percent       PIC Z9.99.
       01  switch-wins-percent     PIC Z9.99.

       PROCEDURE DIVISION.
           PERFORM Num-Games TIMES
               MOVE 0 TO doors (winner)

               CALL "get-rand-int" USING CONTENT One, Three,
                   REFERENCE winner
               MOVE 1 TO doors (winner)

               CALL "get-rand-int" USING CONTENT One, Three,
                   REFERENCE choice

               PERFORM WITH TEST AFTER
                       UNTIL NOT(shown = winner OR choice)
                   CALL "get-rand-int" USING CONTENT One, Three,
                       REFERENCE shown
               END-PERFORM

               ADD doors (choice) TO stay-wins
               ADD doors (6 - choice - shown) TO switch-wins
           END-PERFORM

           COMPUTE stay-wins-percent ROUNDED =
               stay-wins / Num-Games * 100
           COMPUTE switch-wins-percent ROUNDED =
               switch-wins / Num-Games * 100

           DISPLAY "Staying wins   " stay-wins " times ("
               stay-wins-percent "%)."
           DISPLAY "Switching wins " switch-wins " times ("
               switch-wins-percent "%)."
           .

       IDENTIFICATION DIVISION.
       PROGRAM-ID. get-rand-int.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  call-flag               PIC X VALUE "Y".
           88  first-call          VALUE "Y", FALSE "N".

       01  num-range               PIC 9.

       LINKAGE SECTION.
       01  min-num                 PIC 9.
       01  max-num                 PIC 9.

       01  ret                     PIC 9.

       PROCEDURE DIVISION USING min-num, max-num, ret.
           *> Seed RANDOM once.
           IF first-call
               MOVE FUNCTION RANDOM(FUNCTION CURRENT-DATE (9:8))
                   TO num-range
               SET first-call TO FALSE
           END-IF

           COMPUTE num-range = max-num - min-num + 1
           COMPUTE ret =
              FUNCTION MOD(FUNCTION RANDOM * 100000, num-range)
              + min-num
           .
       END PROGRAM get-rand-int.

       END PROGRAM monty-hall.


%%% For details of the algorithms used see
%%% https://en.wikipedia.org/wiki/Modular_exponentiation

-module modexp_rosetta.
-export [mod_exp/3,binary_exp/2,test/0].

mod_exp(Base,Exp,Mod) when
      is_integer(Base),
      is_integer(Exp),
      is_integer(Mod),
      Base > 0,
      Exp > 0,
      Mod > 0 ->
    binary_exp_mod(Base,Exp,Mod).

binary_exp(Base,Exponent) ->
    binary_exp(Base,Exponent,1).
binary_exp(_,0,Result) ->
    Result;
binary_exp(Base,Exponent,Acc) ->
    binary_exp(Base*Base,Exponent bsr 1,Acc * exp_factor(Base,Exponent)).

binary_exp_mod(Base,Exponent,Mod) ->
    binary_exp_mod(Base rem Mod,Exponent,Mod,1).
binary_exp_mod(_,0,_,Result) ->
   Result;
binary_exp_mod(Base,Exponent,Mod,Acc) ->
    binary_exp_mod((Base*Base) rem Mod,
		   Exponent bsr 1,Mod,(Acc * exp_factor(Base,Exponent))rem Mod).

exp_factor(_,0) ->
    1;
exp_factor(Base,1) ->
    Base;
exp_factor(Base,Exponent) ->
    exp_factor(Base,Exponent band 1).

test() ->
    445 = mod_exp(4,13,497),
    %% Rosetta code example:
    mod_exp(2988348162058574136915891421498819466320163312926952423791023078876139,
	    2351399303373464486466122544523690094744975233415544072992656881240319,
	    binary_exp(10,40)).


import "/fmt" for Fmt

var MAXITER = 151

var minkowski // predeclare as recursive
minkowski = Fn.new { |x|
    if (x > 1 || x < 0) return x.floor + minkowski.call(x - x.floor)
    var p = x.floor
    var q = 1
    var r = p + 1
    var s = 1
    var d = 1
    var y = p
    while (true) {
        d = d / 2
        if (y + d == y) break
        var m = p + r
        if (m < 0 || p < 0 ) break
        var n = q + s
        if (n < 0) break
        if (x < m/n) {
            r = m
            s = n
        } else {
            y = y + d
            p = m
            q  = n
        }
    }
    return y + d
}

var minkowskiInv
minkowskiInv = Fn.new { |x|
    if (x > 1 || x < 0) return x.floor + minkowskiInv.call(x - x.floor)
    if (x == 1 || x == 0) return x
    var contFrac = [0]
    var curr = 0
    var count = 1
    var i = 0
    while (true) {
        x = x * 2
        if (curr == 0) {
            if (x < 1) {
                count = count + 1
            } else {
                i = i + 1
                var t = contFrac
                contFrac = List.filled(i + 1, 0)
                for (j in 0...t.count) contFrac[j] = t[j]
                contFrac[i-1] = count
                count = 1
                curr = 1
                x = x - 1
            }
        } else {
            if (x > 1) {
                count = count + 1
                x = x - 1
            } else {
                i = i + 1
                var t = contFrac
                contFrac = List.filled(i + 1, 0)
                for (j in 0...t.count) contFrac[j] = t[j]
                contFrac[i-1] = count
                count = 1
                curr = 0
            }
        }
        if (x == x.floor) {
            contFrac[i] = count
            break
        }
        if (i == MAXITER) break
    }
    var ret = 1/contFrac[i]
    for (j in i-1..0) ret = contFrac[j] + 1/ret
    return 1/ret
}

Fmt.print("$17.16f $17.14f", minkowski.call(0.5 * (1 + 5.sqrt)), 5/3)
Fmt.print("$17.14f $17.14f", minkowskiInv.call(-5/9), (13.sqrt - 7)/6)
Fmt.print("$17.14f $17.14f", minkowski.call(minkowskiInv.call(0.718281828)),
                             minkowskiInv.call(minkowski.call(0.1213141516171819)))


<cfscript>
    function runmontyhall(num_tests) {
	// number of wins when player switches after original selection
	switch_wins	= 0;
	// number of wins when players "sticks" with original selection
	stick_wins  = 0;
	// run all the tests
	for(i=1;i<=num_tests;i++) {
	    // unconditioned potential for selection of each door
	    doors 	= [0,0,0];
	    // winning door is randomly assigned...
	    winner 	= randrange(1,3);
	    // ...and actualized in the array of real doors
	    doors[winner] = 1;
	    // player chooses one of three doors
	    choice 	= randrange(1,3);
	    do {
		// monty randomly reveals a door...
		shown = randrange(1,3);
	    }
	    // ...but monty only reveals empty doors;
	    // he will not reveal the door that the player has choosen
	    // nor will he reveal the winning door
	    while(shown==choice || doors[shown]==1);
	    // when the door the player originally selected is the winner, the "stick" option gains a point
	    stick_wins  += doors[choice];
	    // to calculate the number of times the player would have won with a "switch", subtract the
	    // "value" of the chosen, "stuck-to" door from 1, the possible number of wins if the player
	    // chose and stuck with the winning door (1), the player would not have won by switching, so
	    // the value is 1-1=0 if the player chose and stuck with a losing door (0), the player would
	    // have won by switching, so the value is 1-0=1
	    switch_wins += 1-doors[choice];
	}
	// finally, simply run the percentages for each outcome
	stick_percentage	= (stick_wins/num_tests)*100;
	switch_percentage	= (switch_wins/num_tests)*100;
	writeoutput('Number of Tests:  ' & num_tests);
	writeoutput('
Stick Wins: ' & stick_wins & '  ['& stick_percentage &'%]');
	writeoutput('
Switch Wins: ' & switch_wins & '  ['& switch_percentage &'%]');
    }
    runmontyhall(10000);
</cfscript>


(defun make-round ()
  (let ((array (make-array 3
                           :element-type 'bit
                           :initial-element 0)))
    (setf (bit array (random 3)) 1)
    array))

(defun show-goat (initial-choice array)
  (loop for i = (random 3)
        when (and (/= initial-choice i)
                  (zerop (bit array i)))
          return i))

(defun won? (array i)
  (= 1 (bit array i)))