Basics of Ada
Description of the page content
Conversion of old BASIC programs to Ada in order to learn the basics of this language.
Tags:
3D Plot
-- 3D Plot
--
-- Original version in BASIC:
-- 3-D Plot (by Mark Bramhall), 1978.
-- Creative Computing's BASIC Games.
-- - http://vintage-basic.net/games.html
-- - http://vintage-basic.net/bcg/3dplot.bas
-- - https://www.atariarchives.org/basicgames/showpage.php?page=167
--
-- This version in Ada:
-- Copyright (c) 2025, Marcos Cruz (programandala.net);
-- SPDX-License-Identifier: Fair
--
-- Written on 2025-03-19, 2025-03-29.
--
-- Last modified: 20260824T1919+0200.
with ada.numerics; use ada.numerics;
with ada.numerics.elementary_functions; use ada.numerics.elementary_functions;
with ada.text_io; use ada.text_io;
procedure plot_3d is
procedure move_cursor_home is
escape : constant character := character'val (16#1B#); -- 0x1B
begin
put (escape & "[H");
end move_cursor_home;
procedure erase_screen is
escape : constant character := character'val (16#1B#); -- 0x1B
begin
put (escape & "[2J");
end erase_screen;
procedure clear_screen is
begin
erase_screen;
move_cursor_home;
end clear_screen;
procedure wait_for_keypress (expected_char : character) is
pressed_char : character;
is_a_char_available : boolean;
begin
loop
ada.text_io.get_immediate (pressed_char, is_a_char_available);
if (pressed_char = expected_char) then
exit;
end if;
end loop;
end wait_for_keypress;
procedure print_credits is
begin
put_line ("3D Plot");
new_line;
put_line ("Original version in BASIC:");
put_line (" Creative computing (Morristown, New Jersey, USA), ca. 1980.");
new_line;
put_line ("This version in Ada:");
put_line (" Copyright (c) 2025, Marcos Cruz (programandala.net)");
put_line (" SPDX-License-Identifier: Fair");
new_line;
put ("Press Enter to start the program. ");
wait_for_keypress (character'val (16#0a#)); -- 0x0a, the enter character
end print_credits;
function a (z : float) return float is
begin
return 30.0 * exp (-z * z / 100.0);
end a;
procedure draw is
space : constant character := ' ';
dot : constant character := '*';
width : constant integer := 56;
l : integer;
z : integer;
y : integer;
y1 : integer;
line : array (0 .. width - 1) of character;
x : float := -30.0;
begin
while x <= 30.0 loop
for c in 0 .. width - 1 loop
line (c) := space;
end loop;
l := 0;
y1 :=
5
* integer (
float'truncation (sqrt (900.0 - x * x) / 5.0)
);
y := y1;
while y >= -y1 loop
z := integer (
float'truncation (
25.0
+ a (sqrt (x * x + float (y * y)))
- 0.7 * float (y)
)
);
if z > l then
l := z;
line (z) := dot;
end if;
y := y - 5;
end loop;
for pos in 0 .. width - 1 loop
put (line (pos));
end loop;
new_line;
x := x + 1.5;
end loop;
end draw;
begin
clear_screen;
print_credits;
clear_screen;
draw;
end plot_3d;
Bagels
-- Bagels
-- Original version in BASIC:
-- D. Resek, P. Rowe, 1978.
-- Creative Computing (Morristown, New Jersey, USA), 1978.
-- This version in Ada:
-- Copyright (c) 2026, Marcos Cruz (programandala.net)
-- SPDX-License-Identifier: Fair
--
-- Written in 2026-08/09.
--
-- Last modified: 20260915T1710+0200.
with ada.characters.handling;
with ada.numerics.discrete_random;
with ada.strings.bounded;
with ada.strings.fixed;
with ada.strings.unbounded;
with ada.strings;
with ada.text_io.unbounded_io; use ada.text_io.unbounded_io;
with ada.text_io; use ada.text_io;
procedure bagels is
number_of_digits : constant integer := 3;
subtype digits_range is integer range 1 .. number_of_digits;
min_digit : constant integer := 0;
max_digit : constant integer := 9;
tries : constant integer := 20;
subtype valid_digit is integer range min_digit .. max_digit;
type set_of_digits is array (digits_range) of valid_digit;
escape : constant character := character'val (16#1B#); -- 0x1B
procedure move_cursor_home is
begin
put (escape & "[H");
end move_cursor_home;
procedure erase_screen is
begin
put (escape & "[2J");
end erase_screen;
procedure clear_screen is
begin
erase_screen;
move_cursor_home;
end clear_screen;
function command (prompt : string := "> ") return ada.strings.unbounded.unbounded_string is
begin
put (prompt);
return ada.strings.unbounded.to_unbounded_string (get_line);
end command;
procedure wait_for_keypress (prompt : string) is
enter_key_char : constant character := character'val (10);
pressed_char : character := character'val (0);
begin
put (prompt);
while pressed_char /= enter_key_char loop
ada.text_io.get_immediate (pressed_char);
end loop;
end wait_for_keypress;
function is_affirmative (raw_answer : ada.strings.unbounded.unbounded_string) return boolean is
-- XXX somehow `use` is required to prevent a visibility error in the
-- `if` condition of the loop.
use ada.strings.unbounded;
answer : string := ada.characters.handling.to_lower (ada.strings.unbounded.to_string (raw_answer));
affirmative_answer : constant array(0 .. 3) of ada.strings.unbounded.unbounded_string :=
(
ada.strings.unbounded.to_unbounded_string ("y"),
ada.strings.unbounded.to_unbounded_string ("yeah"),
ada.strings.unbounded.to_unbounded_string ("yes"),
ada.strings.unbounded.to_unbounded_string ("ok")
);
begin
for i in affirmative_answer'range loop
if answer = affirmative_answer(i) then
return true;
end if;
end loop;
return false;
end is_affirmative;
function is_negative (raw_answer : ada.strings.unbounded.unbounded_string) return boolean is
-- XXX somehow `use` is required to prevent a visibility error in the
-- `if` condition of the loop.
use ada.strings.unbounded;
answer : string := ada.characters.handling.to_lower (ada.strings.unbounded.to_string (raw_answer));
negative_answer : constant array(0 .. 2) of ada.strings.unbounded.unbounded_string :=
(
ada.strings.unbounded.to_unbounded_string ("n"),
ada.strings.unbounded.to_unbounded_string ("no"),
ada.strings.unbounded.to_unbounded_string ("nope")
);
begin
for i in negative_answer'range loop
if answer = negative_answer(i) then
return true;
end if;
end loop;
return false;
end is_negative;
function yes (prompt : string) return boolean is
answer : ada.strings.unbounded.unbounded_string;
begin
while not (is_affirmative (answer) or else is_negative (answer)) loop
answer := command (prompt);
end loop;
return is_affirmative (answer);
end yes;
procedure print_credits is
begin
clear_screen;
put_line ("Bagels");
put_line ("Number guessing game");
new_line;
put_line ("Original source unknown but suspected to be:");
put_line (" Lawrence Hall of Science, U.C. Berkely.");
new_line;
put_line ("Original version in BASIC:");
put_line (" D. Resek, P. Rowe, 1978.");
put_line (" Creative computing (Morristown, New Jersey, USA), 1978.");
new_line;
put_line ("This version in Ada:");
put_line (" Copyright (c) 2026, Marcos Cruz (programandala.net)");
put_line (" SPDX-License-Identifier: Fair");
new_line;
wait_for_keypress ("Press Enter to read the instructions. ");
end print_credits;
procedure print_instructions is
begin
clear_screen;
put_line ("Bagels");
put_line ("Number guessing game");
new_line;
put_line ("I am thinking of a three-digit number that has no two digits the same.");
put_line ("Try to guess it and I will give you clues as follows:");
new_line;
put_line (" PICO - one digit correct but in the wrong position");
put_line (" FERMI - one digit correct and in the right position");
put_line (" BAGELS - no digits correct");
new_line;
wait_for_keypress ("Press Enter to start. ");
end print_instructions;
function is_numeric (text : string) return boolean is
begin
for character_position in text'range loop
if not ada.characters.handling.is_digit (text (character_position)) then
return false;
end if;
end loop;
return true;
end is_numeric;
function input (prompt : string) return set_of_digits is
user_input : ada.strings.unbounded.unbounded_string;
user_digit : set_of_digits;
function has_duplicated_digits(input : string) return boolean is
used_digit : array (valid_digit) of boolean;
digit : integer;
are_there_duplicated_digits : boolean := false;
begin
for d in used_digit'range loop
used_digit(d) := false;
end loop;
for position in input'range loop
digit := integer'value ("" & input (position));
if used_digit(digit) = true then
return true;
else
used_digit(digit) := true;
end if;
end loop;
return false;
end has_duplicated_digits;
begin
loop
user_input := command (prompt);
declare
fixed_user_input : string := ada.strings.unbounded.to_string (user_input);
begin
if fixed_user_input'length /= number_of_digits then
put_line ("Remember it's a " & number_of_digits'image & "-digit number.");
elsif not is_numeric (fixed_user_input) then
put_line ("What?");
elsif has_duplicated_digits (fixed_user_input) then
put_line ("Remember my number has no two digits the same.");
else
for character_position in digits_range loop
declare
digit_value : valid_digit := valid_digit'value ("" & fixed_user_input (character_position));
begin
user_digit (character_position) := digit_value;
end;
end loop;
exit;
end if;
end;
end loop;
return user_digit;
end input;
procedure play is
score : natural := 0;
fermi_count : natural := 0;
pico_count : natural := 0;
computer_number : set_of_digits;
user_number : set_of_digits;
digit : valid_digit;
package random_digit is new ada.numerics.discrete_random (valid_digit);
random_generator : random_digit.generator;
keep_choosing_a_valid_digit : boolean; -- a workaround required because ada does not have `continue`
begin
random_digit.reset(random_generator);
loop -- game
clear_screen;
for i in digits_range loop
keep_choosing_a_valid_digit := true;
while keep_choosing_a_valid_digit loop
keep_choosing_a_valid_digit := false;
computer_number (i) := random_digit.random (random_generator);
for j in 1 .. i loop
if j /= i and then computer_number (i) = computer_number (j) then
keep_choosing_a_valid_digit := true;
exit;
end if;
end loop;
end loop;
end loop;
put_line ("O.K. I have a number in mind.");
-- put_line ("My number: " & computer_number'image); -- XXX TMP requires ada 2022
for guess in 1 .. tries loop
user_number := input ("Guess #" & ada.strings.fixed.trim(guess'image, ada.strings.left) & ": ");
fermi_count := 0;
pico_count := 0;
for i in digits_range loop
for j in digits_range loop
if computer_number (i) = user_number (j) then
if i = j then
fermi_count := fermi_count + 1;
else
pico_count := pico_count + 1;
end if;
end if;
end loop;
end loop;
for i in 1 .. pico_count loop
put ("PICO ");
end loop;
for i in 1 .. fermi_count loop
put ("FERMI ");
end loop;
if pico_count + fermi_count = 0 then
put ("BAGELS");
end if;
new_line;
if fermi_count = number_of_digits then
put_line ("You got it!!!");
score := score + 1;
exit;
end if;
end loop; -- tries
if fermi_count /= number_of_digits then
put_line ("Oh well.");
put ("That's " & tries'image & " guesses. My number was ");
for i in digits_range loop
put (computer_number (i)'image);
end loop;
put_line (".");
end if;
exit when not yes ("Play again? ");
end loop; -- game
if score /= 0 then
put_line ("A " & score'image & "-point bagels, buff!!");
end if;
put_line ("Hope you had fun. Bye.");
end play;
begin
print_credits;
print_instructions;
play;
end bagels;
Bunny
-- Bunny
--
-- Original version in BASIC:
-- Anonymous, 1978.
-- Creative Computing's BASIC Games.
-- - http://vintage-basic.net/games.html
-- - http://vintage-basic.net/bcg/bunny.bas
-- - http://www.retroarchive.org/cpm/games/ccgames.zip
--
-- This version in Ada:
-- Copyright (c) 2025, Marcos Cruz (programandala.net)
-- SPDX-License-Identifier: Fair
--
-- Written on 2025-03-29, 2025-03-31, 2025-04-17.
--
-- Last modified: 20260824T1919+0200.
with ada.text_io; use ada.text_io;
procedure bunny is
width : constant integer := 53;
type line_index is range 1 .. width;
type line_array is array (line_index) of character;
-- Clear the terminal and move the cursor to the top left position.
procedure clear_screen is
escape : constant character := character'val (16#1B#); -- 0x1B
begin
put (escape & "[0;0H" & escape & "[2J");
end clear_screen;
procedure wait_for_a_keypress is
char : character;
available : boolean := false;
begin
while not available loop
get_immediate (char, available);
end loop;
end wait_for_a_keypress;
procedure print_credits is
begin
put_line ("Bunny");
new_line;
put_line ("Original version in BASIC:");
put_line (" Creative Computing (Morristown, New Jersey, USA), 1978.");
new_line;
put_line ("This version in Ada:");
put_line (" Copyright (c) 2025, Marcos Cruz (programandala.net)");
put_line (" SPDX-License-Identifier: Fair");
new_line;
put ("Press Enter to start the program. ");
wait_for_a_keypress;
end print_credits;
procedure clear_line (line : in out line_array) is
begin
for i in line'range loop
line (i) := ' ';
end loop;
end clear_line;
procedure print_line (line : line_array) is
begin
for i in line'range loop
put (line (i));
end loop;
new_line;
end print_line;
procedure draw is
letters : constant integer := 5;
type letters_range is range 1 .. letters;
letter : constant array (letters_range) of character :=
('B', 'U', 'N', 'N', 'Y');
EOL : constant integer := -1; -- end of line identifier
data : array (0 .. 226) of integer := (
1, 2, EOL, 0, 2, 45, 50, EOL, 0, 5, 43, 52, EOL, 0, 7, 41,
52, EOL, 1, 9, 37, 50, EOL, 2, 11, 36, 50, EOL, 3, 13, 34,
49, EOL, 4, 14, 32, 48, EOL, 5, 15, 31, 47, EOL, 6, 16, 30,
45, EOL, 7, 17, 29, 44, EOL, 8, 19, 28, 43, EOL, 9, 20, 27,
41, EOL, 10, 21, 26, 40, EOL, 11, 22, 25, 38, EOL, 12, 22,
24, 36, EOL, 13, 34, EOL, 14, 33, EOL, 15, 31, EOL, 17, 29,
EOL, 18, 27, EOL, 19, 26, EOL, 16, 28, EOL, 13, 30, EOL, 11,
31, EOL, 10, 32, EOL, 8, 33, EOL, 7, 34, EOL, 6, 13, 16, 34,
EOL, 5, 12, 16, 35, EOL, 4, 12, 16, 35, EOL, 3, 12, 15, 35,
EOL, 2, 35, EOL, 1, 35, EOL, 2, 34, EOL, 3, 34, EOL, 4, 33,
EOL, 6, 33, EOL, 10, 32, 34, 34, EOL, 14, 17, 19, 25, 28,
31, 35, 35, EOL, 15, 19, 23, 30, 36, 36, EOL, 14, 18, 21,
21, 24, 30, 37, 37, EOL, 13, 18, 23, 29, 33, 38, EOL, 12,
29, 31, 33, EOL, 11, 13, 17, 17, 19, 19, 22, 22, 24, 31,
EOL, 10, 11, 17, 18, 22, 22, 24, 24, 29, 29, EOL, 22, 23,
26, 29, EOL, 27, 29, EOL, 28, 29, EOL );
line : line_array;
data_index : integer;
first_column : integer;
last_column : integer;
begin
clear_line (line);
data_index := 0;
while data_index < data'length loop
first_column := data (data_index);
data_index := data_index + 1;
if first_column = EOL then
print_line (line);
clear_line (line);
else
last_column := data (data_index);
data_index := data_index + 1;
for column in first_column .. last_column loop
line (line_index (column + 1)) := letter (
letters_range (column mod letters + 1)
);
end loop;
end if;
end loop;
end draw;
begin
clear_screen;
print_credits;
clear_screen;
draw;
end bunny;
Diamond
-- Diamond
--
-- Original version in BASIC:
-- Example included in Vintage BASIC 1.0.3.
-- http://www.vintage-basic.net
--
-- This version in Ada:
-- Copyright (c) 2025, Marcos Cruz (programandala.net)
-- SPDX-License-Identifier: Fair
--
-- Written on 2025-03-19.
--
-- Last modified: 20260824T1919+0200.
with ada.text_io; use ada.text_io;
procedure diamond is
lines : constant integer := 17;
begin
for i in 1 .. lines / 2 + 1 loop
for j in 1 .. (lines + 1) / 2 - i + 1 loop
put (" ");
end loop;
for j in 1 .. i * 2 - 1 loop
put ("*");
end loop;
new_line;
end loop;
for i in 1 .. lines / 2 loop
for j in 1 .. i + 1 loop
put (" ");
end loop;
for j in 1 .. ((lines + 1) / 2 - i) * 2 - 1 loop
put ("*");
end loop;
new_line;
end loop;
end diamond;
Math
-- Math
-- Original version in BASIC:
-- Example included in Vintage BASIC 1.0.3.
-- http://www.vintage-basic.net
-- This version in Ada:
-- Copyright (c) 2025, Marcos Cruz (programandala.net)
-- SPDX-License-Identifier: Fair
-- Written on 2025-05-13, 2025-07-28.
-- Last modified: 20260824T1920+0200.
with ada.float_text_io;
with ada.numerics.elementary_functions; use ada.numerics.elementary_functions;
with ada.text_io; use ada.text_io;
procedure math is
n : float;
result : float;
begin
n := 0.0;
put ("Enter a number: ");
ada.float_text_io.get (n);
result := abs n;
put_line ("ABS($n) --> abs $n --> " & result'image);
put_line ("ATN($n) --> arctan ($n) --> " & arctan (n)'image);
put_line ("COS($n) --> cos ($n) --> " & cos (n)'image);
put_line ("EXP($n) --> exp ($n) --> " & exp (n)'image);
put_line ("INT($n) --> integer ($n) --> " & integer (n)'image);
if n > 0.0 then
put_line ("LOG($n) --> log ($n) --> " & log (n)'image);
else
put_line ("LOG($n) --> log ($n) --> undefined");
end if;
put_line (
"SGN($n) --> integer (float'copy_sign (1.0, $n)) --> "
& integer (float'copy_sign (1.0, n))'image
);
if n >= 0.0 then
put_line ("SQR($n) --> sqrt ($n) --> " & sqrt (n)'image);
else
put_line ("SQR($n) --> sqrt ($n) --> math domain error");
end if;
put_line ("TAN($n) --> tan ($n) --> " & tan (n)'image);
end math;
Name
-- Name
-- Original version in BASIC:
-- Example included in Vintage BASIC 1.0.3.
-- http://www.vintage-basic.net
-- This version in Ada:
-- Copyright (c) 2026, Marcos Cruz (programandala.net)
-- SPDX-License-Identifier: Fair
--
-- Written in 2026-08-20/21.
--
-- Last modified: 20260824T1906+0200.
with ada.integer_text_io;
with ada.io_exceptions;
with ada.strings.unbounded;
with ada.text_io; use ada.text_io;
procedure name is
name : ada.strings.unbounded.unbounded_string;
number : integer;
begin
put ("What is your name? ");
name := ada.strings.unbounded.to_unbounded_string (get_line);
loop
begin
put ("Enter a number: ");
ada.integer_text_io.get (number);
exit;
exception
when ada.io_exceptions.data_error =>
put_line ("Number expected. Retry.");
ada.text_io.skip_line;
end;
end loop;
for i in 1 .. number loop
put_line ("Hello, " & ada.strings.unbounded.to_string (name) & "!");
end loop;
end name;
Sine Wave
-- Sine Wave
-- Original version in BASIC:
-- Anonymous, 1978.
-- Creative Computing's BASIC Games.
-- - https://www.atariarchives.org/basicgames/showpage.php?page=146
-- - http://vintage-basic.net/games.html
-- - http://vintage-basic.net/bcg/sinewave.bas
-- - http://www.retroarchive.org/cpm/games/ccgames.zip
-- This version in Ada:
-- Copyright (c) 2025, Marcos Cruz (programandala.net)
-- SPDX-License-Identifier: Fair
-- Written in 2025-03.
--
-- Last modified: 20251204T2300+0100.
with ada.numerics.elementary_functions; use ada.numerics.elementary_functions;
with ada.strings.fixed; use ada.strings.fixed;
with ada.strings.unbounded; use ada.strings.unbounded;
with ada.text_io; use ada.text_io;
procedure sine_wave is
type pair_of_words is array (0 .. 1) of unbounded_string;
procedure clear_screen is
escape : constant character := character'val (16#1B#); -- 0x1B
begin
put (escape & "[0;0H" & escape & "[2J");
end clear_screen;
procedure wait_for_a_keypress is
char : character;
available : boolean := false;
begin
while not available loop
get_immediate (char, available);
end loop;
end wait_for_a_keypress;
procedure print_credits is
begin
clear_screen;
put_line ("Sine Wave");
new_line;
put_line ("Original version in BASIC:");
put_line (" Creative computing (Morristown, New Jersey, USA), ca. 1980.");
new_line;
put_line ("This version in Ada:");
put_line (" Copyright (c) 2025, Marcos Cruz (programandala.net)");
put_line (" SPDX-License-Identifier: Fair");
new_line;
put ("Press Enter to start the program. ");
wait_for_a_keypress;
end print_credits;
procedure draw is
angle : float;
even : boolean := false;
words : pair_of_words;
procedure get_words is
begin
clear_screen;
for n in 0 .. 1 loop
put (
"Enter the "
& (if n = 0 then "first" else "second")
& " word: "
);
words (n) := to_unbounded_string (get_line);
end loop;
end get_words;
begin
clear_screen;
get_words;
clear_screen;
angle := 0.0;
while angle <= 40.0 loop
put (
integer (
float'floor (26.0 + 25.0 * sin (angle))
)
* " "
);
put_line (to_string (words (if even then 1 else 0)));
even := not even;
angle := angle + 0.25;
end loop;
end draw;
begin
print_credits;
draw;
end sine_wave;
Stars
-- Stars
-- Original version in BASIC:
-- Example included in Vintage BASIC 1.0.3.
-- http://www.vintage-basic.net
-- This version in Ada:
-- Copyright (c) 2026, Marcos Cruz (programandala.net)
-- SPDX-License-Identifier: Fair
--
-- Written on 2026-08-21.
--
-- Last modified: 20260824T1918+0200.
with ada.characters.handling;
with ada.integer_text_io;
with ada.io_exceptions;
with ada.strings.unbounded;
with ada.text_io; use ada.text_io;
procedure stars is
answer : ada.strings.unbounded.unbounded_string;
name : ada.strings.unbounded.unbounded_string;
number : integer;
function is_affirmative (raw_answer : string) return boolean is
-- XXX FIXME somehow `use` is required to prevent a visibility error in the
-- `if` condition of the loop.
use ada.strings.unbounded;
answer : string := ada.characters.handling.to_lower (raw_answer);
affirmative_answer : constant array(0 .. 3) of ada.strings.unbounded.unbounded_string :=
(
ada.strings.unbounded.to_unbounded_string ("y"),
ada.strings.unbounded.to_unbounded_string ("yeah"),
ada.strings.unbounded.to_unbounded_string ("yes"),
ada.strings.unbounded.to_unbounded_string ("ok")
);
begin
for i in affirmative_answer'range loop
if answer = affirmative_answer(i) then
return true;
end if;
end loop;
return false;
end is_affirmative;
begin
put ("What is your name? ");
name := ada.strings.unbounded.to_unbounded_string (get_line);
put_line ("Hello, " & ada.strings.unbounded.to_string (name) & ".");
loop
loop
begin
put ("How many stars do you want? ");
ada.integer_text_io.get (number);
exit;
exception
when ada.io_exceptions.data_error =>
put_line ("Number expected. Retry.");
ada.text_io.skip_line;
end;
end loop;
for s in 1 .. number loop
put ("*");
end loop;
new_line;
put ("Do you want more stars? ");
skip_line;
answer :=
ada.strings.unbounded.trim (
ada.strings.unbounded.to_unbounded_string (get_line),
ada.strings.both
);
if not is_affirmative (ada.strings.unbounded.to_string (answer)) then
exit;
end if;
end loop;
put_line ("Goodbye, " & ada.strings.unbounded.to_string (name) & ".");
end stars;
Strings
-- Original version in BASIC:
-- Example included in Vintage BASIC 1.0.3.
-- http://www.vintage-basic.net
-- This version in Ada:
-- Copyright (c) 2026, Marcos Cruz (programandala.net)
-- SPDX-License-Identifier: Fair
-- Written in 2026-08-21/25.
-- Last modified: 20260915T1718+0200.
with ada.integer_text_io;
with ada.io_exceptions;
with ada.strings;
with ada.strings.unbounded; use ada.strings.unbounded;
with ada.text_io; use ada.text_io;
with ada.text_io.unbounded_io; use ada.text_io.unbounded_io;
-- XXX TODO support utf-8
procedure strings is
quote : constant string := """";
s : unbounded_string;
n : integer;
function quoted (s : unbounded_string) return unbounded_string is
begin
return quote & s & quote;
end quoted;
function val_or_0 (s : unbounded_string) return integer is
result : integer;
begin
loop
begin
result := integer'value (to_string (s));
exit;
exception
when others =>
result := 0;
exit;
end;
end loop;
return result;
end val_or_0;
begin
put ("Enter a string: ");
s := get_line;
loop
begin
put ("Enter a number: ");
ada.integer_text_io.get (n);
exit;
exception
when ada.io_exceptions.data_error =>
put_line ("Not a valid number.");
skip_line;
end;
end loop;
put ("ASC(" & quoted (s) & ") --> ");
put (
"integer'image (character'pos (to_string ("
& quoted (s)
& ") (to_string ("
& quoted (s)
& ")'first))) --> "
);
put_line (integer'image (character'pos (to_string (s) (to_string (s)'first))));
put ("CHR$(" & n'image & ") --> ");
put (""""" & character'val (" & n'image & ") --> ");
put_line (quote & character'val (n) & quote);
put ("LEFT$(" & quoted (s) & ", " & n'image & ") --> ");
put (
"trim (head ("
& quoted (s)
& ", "
& n'image
& "), ada.strings.right) --> "
);
put_line (quote & trim (head (s, n), ada.strings.right) & quote);
put ("MID$(" & quoted (s) & ", " & n'image & ") --> ");
put (
"(if " & n'image & " > length (" & quoted (s) & ") then """" else "
& "slice ("
& quoted (s)
& ", "
& n'image
& ", length ("
& quoted (s)
& "))) --> "
);
put_line (
quote
& (
if n > length (s) then
""
else
slice (s, n, length (s))
)
& quote
);
put ("MID$(" & quoted (s) & ", " & n'image & ", 3) --> ");
put (
"(if " & n'image & " > length (" & quoted (s) & ") then """" else "
& "slice ("
& quoted (s)
& ", "
& n'image
& ", "
& n'image
& " + 3 - 1)) --> "
);
put_line (
quote
& (
if n > length (s) then
""
else
slice (s, n, integer'min (length (s), n + 3 - 1))
)
& quote
);
put ("RIGHT$(" & quoted (s) & ", " & n'image & ") --> ");
put (
"trim (tail ("
& quoted (s)
& ", "
& n'image
& "), ada.strings.left) --> "
);
put_line (
quote
& trim (
tail (s, n),
ada.strings.left
)
& quote
);
put ("LEN(" & quoted (s) & ") --> ");
put ("length (" & quoted (s) & ") --> ");
put_line (length (s)'image);
put ("VAL(" & quoted (s) & ") --> ");
put ("val_or_0 (" & quoted (s) & ")'image -- ad hoc function --> ");
put_line (val_or_0 (s)'image);
put ("STR$(" & n'image & ") --> ");
put (
"trim (to_unbounded_string ("
& n'image
& "'image), ada.strings.left) --> "
);
put_line (
quote
&
trim (
to_unbounded_string (n'image),
ada.strings.left
)
& quote
);
put ("SPC(" & n'image & ") --> ");
put (n'image & " * ' ' --> ");
put_line (quote & (n * " ") & quote);
end strings;