Sync
This commit is contained in:
Ingy döt Net
parent
6f050a029e
commit
776bba907c
3887 changed files with 59894 additions and 7280 deletions
259
Task/Quaternion-type/ALGOL-68/quaternion-type-1.alg
Normal file
259
Task/Quaternion-type/ALGOL-68/quaternion-type-1.alg
Normal file
|
|
@ -0,0 +1,259 @@
|
|||
# -*- coding: utf-8 -*- #
|
||||
|
||||
COMMENT REQUIRES:
|
||||
MODE QUATSCAL = REAL; # Scalar #
|
||||
QUATSCAL quat small scal = small real;
|
||||
END COMMENT
|
||||
|
||||
# PROVIDES: #
|
||||
FORMAT quat scal fmt := $g(-0, 4)$;
|
||||
FORMAT signed fmt = $b("+", "")f(quat scal fmt)$;
|
||||
|
||||
FORMAT quat fmt = $f(quat scal fmt)"+"f(quat scal fmt)"i+"f(quat scal fmt)"j+"f(quat scal fmt)"k"$;
|
||||
FORMAT squat fmt = $f(signed fmt)f(signed fmt)"i"f(signed fmt)"j"f(signed fmt)"k"$;
|
||||
|
||||
MODE QUAT = STRUCT(QUATSCAL r, i, j, k);
|
||||
QUAT i=(0, 1, 0, 0),
|
||||
j=(0, 0, 1, 0),
|
||||
k=(0, 0, 0, 1);
|
||||
|
||||
MODE QUATCOSCAL = UNION(INT, SHORT REAL, SHORT INT);
|
||||
MODE QUATSUBSCAL = UNION(QUATCOSCAL, QUATSCAL);
|
||||
|
||||
MODE COMPLSCAL = STRUCT(QUATSCAL r, im);
|
||||
# compatable but not the same #
|
||||
MODE ISOQUAT = UNION([]REAL, []INT, []SHORT REAL, []SHORT INT, []QUATSCAL);
|
||||
MODE COQUAT = UNION(COMPLSCAL, QUATCOSCAL, ISOQUAT);
|
||||
MODE SUBQUAT = UNION(COQUAT, QUAT); # subset is itself #
|
||||
|
||||
MODE QUATERNION = QUAT;
|
||||
|
||||
PROC quat fix type error = (QUAT quat, []STRING msg)BOOL: (
|
||||
putf(stand error, ($"Type error:"$,$" "g$, msg, quat fmt, quat, $l$));
|
||||
stop
|
||||
);
|
||||
|
||||
COMMENT
|
||||
For a list of coercions expected in A68 c.f.
|
||||
* http://rosettacode.org/wiki/ALGOL_68#Coercion_.28casting.29 # ...
|
||||
|
||||
Pre-Strong context: Deproceduring, dereferencing & uniting. e.g. OP arguments
|
||||
* soft(deproceduring for assignment),
|
||||
* weak(dereferencing for slicing and OF selection),
|
||||
* meek(dereferencing for indexing, enquiries and PROC calls),
|
||||
* firm(uniting of OPerators),
|
||||
Strong context only: widening (INT=>REAL=>COMPL), rowing (REAL=>[]REAL) & voiding
|
||||
* strong(widening,rowing,voiding for identities/initialisations, arguments and casts et al)
|
||||
Key points:
|
||||
* arguments to OPerators do not widen or row!
|
||||
* UNITING is permitted in OP/String ccontext.
|
||||
|
||||
There are 4 principle scenerios for most operators:
|
||||
+---------------+-------------------------------+-------------------------------+
|
||||
| OP e.g. * | SCALar | QUATernion |
|
||||
+---------------+-------------------------------+-------------------------------+
|
||||
| SCALar | SCAL * SCAL ... inherit | SCAL * QUAT |
|
||||
+---------------+-------------------------------+-------------------------------+
|
||||
| QUATernion | QUAT * SCAL | QUAT * QUAT |
|
||||
+---------------+-------------------------------+-------------------------------+
|
||||
However this is compounded with SUBtypes of the SCALar & isomorphs the QUATernion,
|
||||
e.g.
|
||||
* SCAL may be a superset of SHORT REAL or INT - a widening coercion is required
|
||||
* QUAT may be a superset eg of COMPL or [4]INT
|
||||
* QUAT may be a structural isomorph eg of [4]REAL
|
||||
+---------------+---------------+---------------+---------------+---------------+
|
||||
| OP e.g. * | SUBSCAL | SCALar | COQUAT | QUATernion |
|
||||
+---------------+---------------+---------------+---------------+---------------+
|
||||
| SUBSCAL | | inherit | SUBSCAT*QUAT |
|
||||
+---------------+ inherit +---------------+---------------+
|
||||
| SCALar | | inherit | SCAL * QUAT |
|
||||
+---------------+---------------+---------------+---------------+---------------+
|
||||
| COQUAT | inherit | inherit | inherit | COQUAT*QUAT |
|
||||
+---------------+---------------+---------------+---------------+---------------+
|
||||
| QUATernion | QUAT*SUBSCAL | QUAT*SCAL | QUAT * COQUAT | QUAT * QUAT |
|
||||
+---------------+---------------+---------------+---------------+---------------+
|
||||
Keypoint: if an EXPLICIT QUAT is not involved, then we can simple inherit, OR QUATINIT!
|
||||
END COMMENT
|
||||
|
||||
MODE CLASSQUAT = STRUCT(
|
||||
PROC (REF QUAT #new#, QUATSCAL #r#, QUATSCAL #i#, QUATSCAL #j#, QUATSCAL #k#)REF QUAT new,
|
||||
PROC (REF QUAT #self#)QUAT conjugate,
|
||||
PROC (REF QUAT #self#)QUATSCAL norm sq,
|
||||
PROC (REF QUAT #self#)QUATSCAL norm,
|
||||
PROC (REF QUAT #self#)QUAT reciprocal,
|
||||
PROC (REF QUAT #self#)STRING repr,
|
||||
PROC (REF QUAT #self#)QUAT neg,
|
||||
PROC (REF QUAT #self#, SUBQUAT #other#)QUAT add,
|
||||
PROC (REF QUAT #self#, SUBQUAT #other#)QUAT radd,
|
||||
PROC (REF QUAT #self#, SUBQUAT #other#)QUAT sub,
|
||||
PROC (REF QUAT #self#, SUBQUAT #other#)QUAT mul,
|
||||
PROC (REF QUAT #self#, SUBQUAT #other#)QUAT rmul,
|
||||
PROC (REF QUAT #self#, SUBQUAT #other#)QUAT div,
|
||||
PROC (REF QUAT #self#, SUBQUAT #other#)QUAT rdiv,
|
||||
PROC (REF QUAT #self#)QUAT exp
|
||||
);
|
||||
|
||||
CLASSQUAT class quat = (
|
||||
|
||||
# PROC new =#(REF QUAT new, QUATSCAL r, i, j, k)REF QUAT: (
|
||||
# 'Defaults all parts of quaternion to zero' #
|
||||
IF new ISNT REF QUAT(NIL) THEN new ELSE HEAP QUAT FI := (r, i, j, k)
|
||||
),
|
||||
|
||||
# PROC conjugate =#(REF QUAT self)QUAT:
|
||||
(r OF self, -i OF self, -j OF self, -k OF self),
|
||||
|
||||
# PROC norm sq =#(REF QUAT self)QUATSCAL:
|
||||
r OF self**2 + i OF self**2 + j OF self**2 + k OF self**2,
|
||||
|
||||
# PROC norm =#(REF QUAT self)QUATSCAL:
|
||||
sqrt((norm sq OF class quat)(self)),
|
||||
|
||||
# PROC reciprocal =#(REF QUAT self)QUAT:(
|
||||
QUATSCAL n2 = (norm sq OF class quat)(self);
|
||||
QUAT conj = (conjugate OF class quat)(self);
|
||||
(r OF conj/n2, i OF conj/n2, j OF conj/n2, k OF conj/n2)
|
||||
),
|
||||
|
||||
# PROC repr =#(REF QUAT self)STRING: (
|
||||
# 'Shorter form of Quaternion as string' #
|
||||
FILE f; STRING s; associate(f, s);
|
||||
putf(f, (squat fmt, r OF self>=0, r OF self,
|
||||
i OF self>=0, i OF self, j OF self>=0, j OF self, k OF self>=0, k OF self));
|
||||
close(f);
|
||||
s
|
||||
),
|
||||
|
||||
# PROC neg =#(REF QUAT self)QUAT:
|
||||
(-r OF self, -i OF self, -j OF self, -k OF self),
|
||||
|
||||
# PROC add =#(REF QUAT self, SUBQUAT other)QUAT:
|
||||
CASE other IN
|
||||
(QUAT other): (r OF self + r OF other, i OF self + i OF other, j OF self + j OF other, k OF self + k OF other),
|
||||
(QUATSUBSCAL other): (r OF self + QUATSCALINIT other, i OF self, j OF self, k OF self)
|
||||
OUT IF quat fix type error(SKIP,"in add") THEN SKIP ELSE stop FI
|
||||
ESAC,
|
||||
|
||||
# PROC radd =#(REF QUAT self, SUBQUAT other)QUAT:
|
||||
(add OF class quat)(self, other),
|
||||
|
||||
# PROC sub =#(REF QUAT self, SUBQUAT other)QUAT:
|
||||
CASE other IN
|
||||
(QUAT other): (r OF self - r OF other, i OF self - i OF other, j OF self - j OF other, k OF self - k OF other),
|
||||
(QUATSCAL other): (r OF self - other, i OF self, j OF self, k OF self)
|
||||
OUT IF quat fix type error(self,"in sub") THEN SKIP ELSE stop FI
|
||||
ESAC,
|
||||
|
||||
# PROC mul =#(REF QUAT self, SUBQUAT other)QUAT:
|
||||
CASE other IN
|
||||
(QUAT other):(
|
||||
r OF self*r OF other - i OF self*i OF other - j OF self*j OF other - k OF self*k OF other,
|
||||
r OF self*i OF other + i OF self*r OF other + j OF self*k OF other - k OF self*j OF other,
|
||||
r OF self*j OF other - i OF self*k OF other + j OF self*r OF other + k OF self*i OF other,
|
||||
r OF self*k OF other + i OF self*j OF other - j OF self*i OF other + k OF self*r OF other
|
||||
),
|
||||
(QUATSCAL other): ( r OF self * other, i OF self * other, j OF self * other, k OF self * other)
|
||||
OUT IF quat fix type error(self,"in mul") THEN SKIP ELSE stop FI
|
||||
ESAC,
|
||||
|
||||
# PROC rmul =#(REF QUAT self, SUBQUAT other)QUAT:
|
||||
CASE other IN
|
||||
(QUAT other): (mul OF class quat)(LOC QUAT := other, self),
|
||||
(QUATSCAL other): (mul OF class quat)(self, other)
|
||||
OUT IF quat fix type error(self,"in rmul") THEN SKIP ELSE stop FI
|
||||
ESAC,
|
||||
|
||||
# PROC div =#(REF QUAT self, SUBQUAT other)QUAT:
|
||||
CASE other IN
|
||||
(QUAT other): (mul OF class quat)(self, (reciprocal OF class quat)(LOC QUAT := other)),
|
||||
(QUATSCAL other): (mul OF class quat)(self, 1/other)
|
||||
OUT IF quat fix type error(self,"in div") THEN SKIP ELSE stop FI
|
||||
ESAC,
|
||||
|
||||
# PROC rdiv =#(REF QUAT self, SUBQUAT other)QUAT:
|
||||
CASE other IN
|
||||
(QUAT other): (div OF class quat)(LOC QUAT := other, self),
|
||||
(QUATSCAL other): (div OF class quat)(LOC QUAT := (other, 0, 0, 0), self)
|
||||
OUT IF quat fix type error(self,"in rdiv") THEN SKIP ELSE stop FI
|
||||
ESAC,
|
||||
|
||||
# PROC exp =#(REF QUAT self)QUAT: (
|
||||
QUAT fac := self;
|
||||
QUAT sum := 1.0 + fac;
|
||||
FOR i FROM 2 TO bits width WHILE ABS(fac + quat small scal) /= quat small scal DO
|
||||
VOID(sum +:= (fac *:= self / ##QUATSCAL(i)))
|
||||
OD;
|
||||
sum
|
||||
)
|
||||
);
|
||||
|
||||
PRIO INIT = 1;
|
||||
OP QUATSCALINIT = (QUATSUBSCAL scal)QUATSCAL:
|
||||
CASE scal IN
|
||||
(INT scal): scal,
|
||||
(SHORT INT scal): scal,
|
||||
(SHORT REAL scal): scal
|
||||
OUT IF quat fix type error(SKIP,"in QUATSCALINIT") THEN SKIP ELSE stop FI
|
||||
ESAC;
|
||||
|
||||
OP INIT = (REF QUAT new, SUBQUAT from)REF QUAT:
|
||||
new :=
|
||||
CASE from IN
|
||||
(QUATSUBSCAL scal):(QUATSCALINIT scal, 0, 0, 0)
|
||||
#(COQUAT rijk):(new OF class quat)(LOC QUAT := new, rijk[1], rijk[2], rijk[3], rijk[4]),#
|
||||
OUT IF quat fix type error(SKIP,"in INIT") THEN SKIP ELSE stop FI
|
||||
ESAC;
|
||||
|
||||
|
||||
OP QUATINIT = (COQUAT lhs)REF QUAT: (HEAP QUAT)INIT lhs;
|
||||
|
||||
OP + = (QUAT q)QUAT: q,
|
||||
- = (QUAT q)QUAT: (neg OF class quat)(LOC QUAT := q),
|
||||
CONJ = (QUAT q)QUAT: (conjugate OF class quat)(LOC QUAT := q),
|
||||
ABS = (QUAT q)QUATSCAL: (norm OF class quat)(LOC QUAT := q),
|
||||
REPR = (QUAT q)STRING: (repr OF class quat)(LOC QUAT := q);
|
||||
# missing: Diadic: I, J, K END #
|
||||
|
||||
OP +:= = (REF QUAT a, QUAT b)QUAT: a:=( add OF class quat)(a, b),
|
||||
+:= = (REF QUAT a, COQUAT b)QUAT: a:=( add OF class quat)(a, b),
|
||||
+=: = (QUAT a, REF QUAT b)QUAT: b:=(radd OF class quat)(b, a),
|
||||
+=: = (COQUAT a, REF QUAT b)QUAT: b:=(radd OF class quat)(b, a);
|
||||
# missing: Worthy PLUSAB, PLUSTO for SHORT/LONG INT QUATSCAL & COMPL #
|
||||
|
||||
OP -:= = (REF QUAT a, QUAT b)QUAT: a:=( sub OF class quat)(a, b),
|
||||
-:= = (REF QUAT a, COQUAT b)QUAT: a:=( sub OF class quat)(a, b);
|
||||
# missing: Worthy MINUSAB for SHORT/LONG INT ##COQUAT & COMPL #
|
||||
|
||||
PRIO *=: = 1, /=: = 1;
|
||||
OP *:= = (REF QUAT a, QUAT b)QUAT: a:=( mul OF class quat)(a, b),
|
||||
*:= = (REF QUAT a, COQUAT b)QUAT: a:=( mul OF class quat)(a, b),
|
||||
*=: = (QUAT a, REF QUAT b)QUAT: b:=(rmul OF class quat)(b, a),
|
||||
*=: = (COQUAT a, REF QUAT b)QUAT: b:=(rmul OF class quat)(b, a);
|
||||
# missing: Worthy TIMESAB, TIMESTO for SHORT/LONG INT ##COQUAT & COMPL #
|
||||
|
||||
OP /:= = (REF QUAT a, QUAT b)QUAT: a:=( div OF class quat)(a, b),
|
||||
/:= = (REF QUAT a, COQUAT b)QUAT: a:=( div OF class quat)(a, b),
|
||||
/=: = (QUAT a, REF QUAT b)QUAT: b:=(rdiv OF class quat)(b, a),
|
||||
/=: = (COQUAT a, REF QUAT b)QUAT: b:=(rdiv OF class quat)(b, a);
|
||||
# missing: Worthy OVERAB, OVERTO for SHORT/LONG INT ##COQUAT & COMPL #
|
||||
|
||||
OP + = (QUAT a, b)QUAT: ( add OF class quat)(LOC QUAT := a, b),
|
||||
+ = (QUAT a, COQUAT b)QUAT: ( add OF class quat)(LOC QUAT := a, b),
|
||||
+ = (COQUAT a, QUAT b)QUAT: (radd OF class quat)(LOC QUAT := b, a);
|
||||
|
||||
OP - = (QUAT a, b)QUAT: ( sub OF class quat)(LOC QUAT := a, b),
|
||||
- = (QUAT a, COQUAT b)QUAT: ( sub OF class quat)(LOC QUAT := a, b),
|
||||
- = (COQUAT a, QUAT b)QUAT:-( sub OF class quat)(LOC QUAT := b, a);
|
||||
|
||||
OP * = (QUAT a, b)QUAT: ( mul OF class quat)(LOC QUAT := a, b),
|
||||
* = (QUAT a, COQUAT b)QUAT: ( mul OF class quat)(LOC QUAT := a, b),
|
||||
* = (COQUAT a, QUAT b)QUAT: (rmul OF class quat)(LOC QUAT := b, a);
|
||||
|
||||
OP / = (QUAT a, b)QUAT: ( div OF class quat)(LOC QUAT := a, b),
|
||||
/ = (QUAT a, COQUAT b)QUAT: ( div OF class quat)(LOC QUAT := a, b),
|
||||
/ = (COQUAT a, QUAT b)QUAT:
|
||||
( div OF class quat)(LOC QUAT := QUATINIT 1, a);
|
||||
|
||||
PROC quat exp = (QUAT q)QUAT: (exp OF class quat)(LOC QUAT := q);
|
||||
|
||||
SKIP # missing: quat arc{sin, cos, tan}h, log, exp, ln etc END #
|
||||
55
Task/Quaternion-type/ALGOL-68/quaternion-type-2.alg
Normal file
55
Task/Quaternion-type/ALGOL-68/quaternion-type-2.alg
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
#!/usr/bin/a68g --script #
|
||||
# -*- coding: utf-8 -*- #
|
||||
|
||||
# REQUIRES: #
|
||||
MODE QUATSCAL = REAL; # Scalar #
|
||||
QUATSCAL quat small scal = small real;
|
||||
|
||||
PR READ "prelude/Quaternion.a68" PR;
|
||||
|
||||
test:(
|
||||
REAL r = 7;
|
||||
QUAT q = (1, 2, 3, 4),
|
||||
q1 = (2, 3, 4, 5),
|
||||
q2 = (3, 4, 5, 6);
|
||||
|
||||
printf((
|
||||
$"r = " f(quat scal fmt)l$, r,
|
||||
$"q = " f(quat fmt)l$, q,
|
||||
$"q1 = " f(quat fmt)l$, q1,
|
||||
$"q2 = " f(quat fmt)l$, q2,
|
||||
$"ABS q = " f(quat scal fmt)", "$, ABS q,
|
||||
$"ABS q1 = " f(quat scal fmt)", "$, ABS q1,
|
||||
$"ABS q2 = " f(quat scal fmt)l$, ABS q2,
|
||||
$"-q = " f(quat fmt)l$, -q,
|
||||
$"CONJ q = " f(quat fmt)l$, CONJ q,
|
||||
$"r + q = " f(quat fmt)l$, r + q,
|
||||
$"q + r = " f(quat fmt)l$, q + r,
|
||||
$"q1 + q2 = "f(quat fmt)l$, q1 + q2,
|
||||
$"q2 + q1 = "f(quat fmt)l$, q2 + q1,
|
||||
$"q * r = " f(quat fmt)l$, q * r,
|
||||
$"r * q = " f(quat fmt)l$, r * q,
|
||||
$"q1 * q2 = "f(quat fmt)l$, q1 * q2,
|
||||
$"q2 * q1 = "f(quat fmt)l$, q2 * q1
|
||||
));
|
||||
|
||||
CO
|
||||
$"ASSERT q1 * q2 != q2 * q1 = "f(quat fmt)l$, ASSERT q1 * q2 != q2 * q1, $l$;
|
||||
END CO
|
||||
|
||||
printf((
|
||||
$"i*i = " f(quat fmt)l$, i*i,
|
||||
$"j*j = " f(quat fmt)l$, j*j,
|
||||
$"k*k = " f(quat fmt)l$, k*k,
|
||||
$"i*j*k = " f(quat fmt)l$, i*j*k,
|
||||
$"q1 / q2 = " f(quat fmt)l$, q1 / q2,
|
||||
$"q1 / q2 * q2 = "f(quat fmt)l$, q1 / q2 * q2,
|
||||
$"q2 * q1 / q2 = "f(quat fmt)l$, q2 * q1 / q2,
|
||||
$"1/q1 * q1 = " f(quat fmt)l$, 1.0/q1 * q1,
|
||||
$"q1 / q1 = " f(quat fmt)l$, q1 / q1,
|
||||
$"quat exp(pi * i) = " f(quat fmt)l$, quat exp(pi * i),
|
||||
$"quat exp(pi * j) = " f(quat fmt)l$, quat exp(pi * j),
|
||||
$"quat exp(pi * k) = " f(quat fmt)l$, quat exp(pi * k)
|
||||
));
|
||||
print((REPR(-q1*q2), ", ", REPR(-q2*q1), new line))
|
||||
)
|
||||
|
|
@ -8,12 +8,16 @@ r=7
|
|||
->Quaternion[3,4,5,6]
|
||||
->7
|
||||
|
||||
Norm[q]
|
||||
->30
|
||||
Abs[q]
|
||||
->√30
|
||||
-q
|
||||
->Quaternion[-1,-2,-3,-4]
|
||||
Conjugate[q]
|
||||
->Quaternion[1,-2,-3,-4]
|
||||
r+q
|
||||
->Quaternion[8,2,3,4]
|
||||
q+r
|
||||
->Quaternion[8,2,3,4]
|
||||
q1+q2
|
||||
->Quaternion[5,7,9,11]
|
||||
q*r
|
||||
|
|
|
|||
136
Task/Quaternion-type/PL-I/quaternion-type.pli
Normal file
136
Task/Quaternion-type/PL-I/quaternion-type.pli
Normal file
|
|
@ -0,0 +1,136 @@
|
|||
*process source attributes xref or(!);
|
||||
qu: Proc Options(main);
|
||||
/**********************************************************************
|
||||
* 06.09.2013 Walter Pachl translated from REXX
|
||||
* added tasks 9 and A
|
||||
**********************************************************************/
|
||||
dcl v(4) Char(1) Var Init('','i','j','k');
|
||||
define structure 1 quat, 2 x(4) Dec Float(15);
|
||||
Dcl q type quat; Call quat_init(q, 1,2,3,4);
|
||||
Dcl q1 type quat; Call quat_init(q1,2,3,4,5);
|
||||
Dcl q2 type quat; Call quat_init(q2,3,4,5,6);
|
||||
Dcl q3 type quat; Call quat_init(q3,-2,3,-4,-5);
|
||||
Dcl r Dec Float(15)Init(7);
|
||||
|
||||
call showq(' ','q' ,q);
|
||||
call showq(' ','q1' ,q1);
|
||||
call showq(' ','q2' ,q2);
|
||||
call showq(' ','q3' ,q3);
|
||||
call shows(' ','r' ,r);
|
||||
Call shows('task 1:','norm q' ,norm(q));
|
||||
Call showq('task 2:','quatneg q' ,quatneg(q));
|
||||
Call showq('task 3:','conjugate q' ,quatConj(q));
|
||||
Call showq('task 4:','addition r+q' ,quatAddsq(r,q));
|
||||
Call showq('task 5:','addition q1+q2' ,quatAdd(q1,q2));
|
||||
Call showq('task 6:','multiplication q*r' ,quatMulqs(q,r));
|
||||
Call showq('task 7:','multiplication q1*q2' ,quatMul(q1,q2));
|
||||
Call showq('task 8:','multiplication q2*q1' ,quatMul(q2,q1));
|
||||
Call showq('task 9:','quatsub q1-q1' ,quatAdd(q1,quatneg(q1)));
|
||||
Call showq('task A:','addition q1+q3' ,quatAdd(q1,q3));
|
||||
Call showt('task B:','equal' ,quatEqual(quatMul(q1,q2),
|
||||
quatMul(q2,q1)));
|
||||
Call showt('task C:','q1=q1' ,quatEqual(q1,q1));
|
||||
|
||||
quatNeg: procedure(qp) Returns(type quat);
|
||||
Dcl (qp,qr) type quat;
|
||||
qr.x(*)=-qp.x(*);
|
||||
Return (qr);
|
||||
End;
|
||||
|
||||
quatAdd: procedure(qp,qq) Returns(type quat);
|
||||
Dcl (qp,qq,qr) type quat;
|
||||
qr.x(*)=qp.x(*)+qq.x(*);
|
||||
Return (qr);
|
||||
End;
|
||||
|
||||
quatAddsq: procedure(v,qp) Returns(type quat);
|
||||
Dcl v Dec Float(15);
|
||||
Dcl (qp,qr) type quat;
|
||||
qr.x(*)=qp.x(*);
|
||||
qr.x(1)=qp.x(1)+v;
|
||||
Return (qr);
|
||||
End;
|
||||
|
||||
quatConj: procedure(qp) Returns(type quat);
|
||||
Dcl (qp,qr) type quat;
|
||||
qr.x(*)=-qp.x(*);
|
||||
qr.x(1)= qp.x(1);
|
||||
Return (qr);
|
||||
End;
|
||||
|
||||
quatMul: procedure(qp,qq) Returns(type quat);
|
||||
Dcl (qp,qq,qr) type quat;
|
||||
qr.x(1)=
|
||||
qp.x(1)*qq.x(1)-qp.x(2)*qq.x(2)-qp.x(3)*qq.x(3)-qp.x(4)*qq.x(4);
|
||||
qr.x(2)=
|
||||
qp.x(1)*qq.x(2)+qp.x(2)*qq.x(1)+qp.x(3)*qq.x(4)-qp.x(4)*qq.x(3);
|
||||
qr.x(3)=
|
||||
qp.x(1)*qq.x(3)-qp.x(2)*qq.x(4)+qp.x(3)*qq.x(1)+qp.x(4)*qq.x(2);
|
||||
qr.x(4)=
|
||||
qp.x(1)*qq.x(4)+qp.x(2)*qq.x(3)-qp.x(3)*qq.x(2)+qp.x(4)*qq.x(1);
|
||||
Return (qr);
|
||||
End;
|
||||
|
||||
quatMulqs: procedure(qp,v) Returns(type quat);
|
||||
Dcl (qp,qr) type quat;
|
||||
Dcl v Dec Float(15);
|
||||
qr.x(*)=qp.x(*)*v;
|
||||
Return (qr);
|
||||
End;
|
||||
|
||||
shows: Procedure(t1,t2,v);
|
||||
Dcl (t1,t2) Char(*);
|
||||
Dcl v Dec Float(15);
|
||||
Put Edit(t1,right(t2,24),' --> ',v)(Skip,a,a,a,f(15,13));
|
||||
End;
|
||||
|
||||
showt: Procedure(t1,t2,v);
|
||||
Dcl (t1,t2) Char(*);
|
||||
Dcl v Char(*) Var);
|
||||
Put Edit(t1,right(t2,24),' --> ',v)(Skip,a,a,a,a);
|
||||
End;
|
||||
|
||||
showq: Procedure(t1,t2,qp);
|
||||
Dcl qp type quat;
|
||||
Dcl (t1,t2) Char(*);
|
||||
Dcl (s,s2,p) Char(100) Var Init('');
|
||||
Dcl i Bin Fixed(31);
|
||||
Put String(s) Edit(t1,right(t2,24),' --> ')(a,a,a);
|
||||
Do i=1 To 4;
|
||||
Put String(p) Edit(abs(qp.x(i)))(p'ZZZ9');
|
||||
p=trim(p);
|
||||
Select;
|
||||
When(qp.x(i)<0) p='-'!!p!!v(i);
|
||||
When(p=0) p='';
|
||||
Otherwise Do
|
||||
If s2^='' Then p='+'!!p;
|
||||
If i>1 Then p=p!!v(i);
|
||||
End;
|
||||
End;
|
||||
s2=s2!!p
|
||||
End;
|
||||
If s2='' Then
|
||||
s2='0';
|
||||
Put Edit(s!!s2)(Skip,a);
|
||||
End;
|
||||
|
||||
norm: Procedure(qp) Returns(Dec Float(15));
|
||||
Dcl qp type quat;
|
||||
Dcl r Dec Float(15) Init(0);
|
||||
Dcl i Bin Fixed(31);
|
||||
Do i=1 To 4;
|
||||
r=r+qp.x(i)**2;
|
||||
End;
|
||||
Return (sqrt(r));
|
||||
End;
|
||||
|
||||
quat_init: Proc(qp,x,y,z,u);
|
||||
Dcl qp type quat;
|
||||
Dcl (x,y,z,u) Dec Float(15);
|
||||
qp.x(1)=x;
|
||||
qp.x(2)=y;
|
||||
qp.x(3)=z;
|
||||
qp.x(4)=u;
|
||||
End;
|
||||
|
||||
End;
|
||||
77
Task/Quaternion-type/Ruby/quaternion-type.rb
Normal file
77
Task/Quaternion-type/Ruby/quaternion-type.rb
Normal file
|
|
@ -0,0 +1,77 @@
|
|||
class Quaternion
|
||||
def initialize(*parts)
|
||||
raise ArgumentError, "wrong number of arguments (#{parts.size} for 4)" unless parts.size == 4
|
||||
raise ArgumentError, "invalid value of quaternion parts #{parts}" unless parts.all? {|x| x.is_a?(Numeric)}
|
||||
@parts = parts
|
||||
end
|
||||
|
||||
def to_a; @parts; end
|
||||
def to_s; "Quaternion#{@parts.to_s}" end
|
||||
alias inspect to_s
|
||||
def complex_parts; [Complex(*to_a[0..1]), Complex(*to_a[2..3])]; end
|
||||
|
||||
def real; @parts.first; end
|
||||
def imag; @parts[1..3]; end
|
||||
def conj; Quaternion.new(real, *imag.map(&:-@)); end
|
||||
def norm; Math.sqrt(to_a.reduce(0){|sum,e| sum + e**2}) end # In Rails: Math.sqrt(to_a.sum { e**2 })
|
||||
|
||||
def ==(other)
|
||||
case other
|
||||
when Quaternion; to_a == other.to_a
|
||||
when Numeric; to_a == [other, 0, 0, 0]
|
||||
else false
|
||||
end
|
||||
end
|
||||
def -@; Quaternion.new(*to_a.map(&:-@)); end
|
||||
def -(other); self + -other; end
|
||||
|
||||
def +(other)
|
||||
case other
|
||||
when Numeric
|
||||
Quaternion.new(real + other, *imag)
|
||||
when Quaternion
|
||||
Quaternion.new(*to_a.zip(other.to_a).map { |x,y| x + y }) # In Rails: zip(other).map(&:sum)
|
||||
end
|
||||
end
|
||||
|
||||
def *(other)
|
||||
case other
|
||||
when Numeric
|
||||
Quaternion.new(*to_a.map { |x| x * other })
|
||||
when Quaternion
|
||||
# Multiplication of quaternions in C x C space. See "Cayley-Dickson construction".
|
||||
a, b, c, d = *complex_parts, *other.complex_parts
|
||||
x, y = a*c - d.conj*b, a*d + b*c.conj
|
||||
Quaternion.new(x.real, x.imag, y.real, y.imag)
|
||||
end
|
||||
end
|
||||
|
||||
# Coerce is called by Ruby to return a compatible type/receiver when the called method/operation does not accept a Quaternion
|
||||
def coerce(other)
|
||||
case other
|
||||
when Numeric then [Scalar.new(other), self]
|
||||
else raise TypeError, "#{other.class} can't be coerced into #{self.class}"
|
||||
end
|
||||
end
|
||||
|
||||
class Scalar
|
||||
def initialize(val); @val = val; end
|
||||
def +(other); other + @val; end
|
||||
def *(other); other * @val; end
|
||||
def -(other); Quaternion.new(@val, 0, 0, 0) - other; end
|
||||
end
|
||||
end
|
||||
|
||||
if __FILE__ == $0
|
||||
q = Quaternion.new(1,2,3,4)
|
||||
q1 = Quaternion.new(2,3,4,5)
|
||||
q2 = Quaternion.new(3,4,5,6)
|
||||
r = 7
|
||||
expressions = ["q", "q1", "q2",
|
||||
"q.norm", "-q", "q.conj", "q + r", "r + q","q1 + q2", "q2 + q1",
|
||||
"q * r", "r * q", "q1 * q2", "q2 * q1", "(q1 * q2 != q2 * q1)",
|
||||
"q - r", "r - q"]
|
||||
expressions.each do |exp|
|
||||
puts "%20s = %s" % [exp, eval(exp)]
|
||||
end
|
||||
end
|
||||
Loading…
Add table
Add a link
Reference in a new issue