aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

Data update

Browse source
This commit is contained in:
Ingy döt Net 2026-02-01 16:33:20 -08:00
parent 5150844a7d
commit 4bb20c9b71
7735 changed files with 38060 additions and 199180 deletions
Download patch file Download diff file Expand all files Collapse all files

143
Task/Death-Star/Ada/death-star.ada
View file

@ -1,143 +0,0 @@
with Ada.Numerics.Elementary_Functions;
with Ada.Numerics.Generic_Real_Arrays;
with SDL.Video.Windows.Makers;
with SDL.Video.Renderers.Makers;
with SDL.Video.Palettes;
with SDL.Events.Events;
procedure Death_Star is
Width : constant := 400;
Height : constant := 400;
package Float_Arrays is
new Ada.Numerics.Generic_Real_Arrays (Float);
use Ada.Numerics.Elementary_Functions;
use Float_Arrays;
Window : SDL.Video.Windows.Window;
Renderer : SDL.Video.Renderers.Renderer;
subtype Vector_3 is Real_Vector (1 .. 3);
type Sphere_Type is record
Cx, Cy, Cz : Integer;
R : Integer;
end record;
function Normalize (V : Vector_3) return Vector_3 is
(V / Sqrt (V * V));
procedure Hit (S : Sphere_Type;
X, Y : Integer;
Z1, Z2 : out Float;
Is_Hit : out Boolean)
is
NX : constant Integer := X - S.Cx;
NY : constant Integer := Y - S.Cy;
Zsq : constant Integer := S.R * S.R - (NX * NX + NY * NY);
Zsqrt : Float;
begin
if Zsq >= 0 then
Zsqrt := Sqrt (Float (Zsq));
Z1 := Float (S.Cz) - Zsqrt;
Z2 := Float (S.Cz) + Zsqrt;
Is_Hit := True;
return;
end if;
Z1 := 0.0;
Z2 := 0.0;
Is_Hit := False;
end Hit;
procedure Draw_Death_Star (Pos, Neg : Sphere_Type;
K, Amb : Float;
Dir : Vector_3)
is
Vec : Vector_3;
ZB1, ZB2 : Float;
ZS1, ZS2 : Float;
Is_Hit : Boolean;
S : Float;
Lum : Integer;
begin
for Y in Pos.Cy - Pos.R .. Pos.Cy + Pos.R loop
for X in Pos.Cx - Pos.R .. Pos.Cx + Pos.R loop
Hit (Pos, X, Y, ZB1, ZB2, Is_Hit);
if not Is_Hit then
goto Continue;
end if;
Hit (Neg, X, Y, ZS1, ZS2, Is_Hit);
if Is_Hit then
if ZS1 > ZB1 then
Is_Hit := False;
elsif ZS2 > ZB2 then
goto Continue;
end if;
end if;
if Is_Hit then
Vec := (Float (Neg.Cx - X),
Float (Neg.Cy - Y),
Float (Neg.Cz) - ZS2);
else
Vec := (Float (X - Pos.Cx),
Float (Y - Pos.Cy),
ZB1 - Float (Pos.Cz));
end if;
S := Float'Max (0.0, Dir * Normalize (Vec));
Lum := Integer (255.0 * (S ** K + Amb) / (1.0 + Amb));
Lum := Integer'Max (0, Lum);
Lum := Integer'Min (Lum, 255);
Renderer.Set_Draw_Colour ((SDL.Video.Palettes.Colour_Component (Lum),
SDL.Video.Palettes.Colour_Component (Lum),
SDL.Video.Palettes.Colour_Component (Lum),
255));
Renderer.Draw (Point => (SDL.C.int (X + Width / 2),
SDL.C.int (Y + Height / 2)));
<<Continue>>
end loop;
end loop;
end Draw_Death_Star;
procedure Wait is
use type SDL.Events.Event_Types;
Event : SDL.Events.Events.Events;
begin
loop
while SDL.Events.Events.Poll (Event) loop
if Event.Common.Event_Type = SDL.Events.Quit then
return;
end if;
end loop;
delay 0.100;
end loop;
end Wait;
Direction : constant Vector_3 := Normalize ((20.0, -40.0, -10.0));
Positive : constant Sphere_Type := (0, 0, 0, 120);
Negative : constant Sphere_Type := (-90, -90, -30, 100);
begin
if not SDL.Initialise (Flags => SDL.Enable_Screen) then
return;
end if;
SDL.Video.Windows.Makers.Create (Win => Window,
Title => "Death star",
Position => SDL.Natural_Coordinates'(X => 10, Y => 10),
Size => SDL.Positive_Sizes'(Width, Height),
Flags => 0);
SDL.Video.Renderers.Makers.Create (Renderer, Window.Get_Surface);
Renderer.Set_Draw_Colour ((0, 0, 0, 255));
Renderer.Fill (Rectangle => (0, 0, Width, Height));
Draw_Death_Star (Positive, Negative, 1.5, 0.2, Direction);
Window.Update_Surface;
Wait;
Window.Finalize;
SDL.Finalise;
end Death_Star;

2
Task/Death-Star/EasyLang/death-star.easy
View file

@ -45,7 +45,7 @@ proc death_star &pos[] &neg[] k amb dir[] .
normalize vec[]
s = vdot dir[] vec[]
if s < 0 : s = 0
lum = 100 * (pow s k + amb) / (1 + amb)
lum = (pow s k + amb) / (1 + amb)
gcolor3 lum lum lum
grect 50 + x / 4, 50 + y / 4, 0.25 0.24
.

81
Task/Death-Star/VBScript/death-star.vb
View file

@ -1,81 +0,0 @@
'deathstar ascii graphics
option explicit
const x_=0
const y_=1
const z_=2
const r_=3
function clamp(x,b,t)
if x<b then
clamp=b
elseif x>t then
clamp =t
else
clamp=x
end if
end function
function dot(v,w) dot=v(x_)*w(x_)+v(y_)*w(y_)+v(z_)*w(z_): end function
function normal (byval v)
dim ilen:ilen=1/sqr(dot(v,v)):
v(x_)=v(x_)*ilen: v(y_)=v(y_)*ilen: v(z_)=v(z_)*ilen:
normal=v:
end function
function hittest(s,x,y)
dim z
z = s(r_)^2 - (x-s(x_))^2 - (y-s(y_))^2
if z>=0 then
z=sqr(z)
hittest=array(s(z_)-z,s(z_)+z)
else
hittest=0
end if
end function
sub deathstar(pos, neg, sun, k, amb)
dim x,y,shades,result,shade,hp,hn,xx,b
shades=array(" ",".",":","!","*","o","e","&","#","%","@")
for y = pos(y_)-pos(r_)-0.5 to pos(y_)+pos(r_)+0.5
for x = pos(x_)-pos(r_)-0.5 to pos(x_)+pos(r_)+.5
hp=hittest (pos, x, y)
hn=hittest(neg,x,y)
if not isarray(hp) then
result=0
elseif not isarray(hn) then
result=1
elseif hn(0)>hp(0) then
result=1
elseif hn(1)>hp(1) then
result=0
elseif hn(1)>hp(0) then
result=2
else
result=1
end if
shade=-1
select case result
case 0
shade=0
case 1
xx=normal(array(x-pos(x_),y-pos(y_),hp(0)-pos(z_)))
'shade=clamp(1-dot(sun,xx)^k+amb,1,ubound(shades))
case 2
xx=normal(array(neg(x_)-x,neg(y_)-y,neg(z_)-hn(1)))
'shade=clamp(1-dot(sun,xx)^k+amb,1,ubound(shades))
end select
if shade <>0 then
b=dot(sun,xx)^k+amb
shade=clamp((1-b) *ubound(shades),1,ubound(shades))
end if
wscript.stdout.write string(2,shades(shade))
next
wscript.stdout.write vbcrlf
next
end sub
deathstar array(20, 20, 0, 20),array(10,10,-15,10), normal(array(-2,1,3)), 2, 0.1