XProfan

'  Screen saver Nr 5048  ;-)
'  (n) Noware 2012-8 P. woodpecker without jegliche Gewähr!
Window Style 64 | 16:Window 0,0-%maxx,%maxy-35
var xm&=%maxx\2:var ym&=(height(%HWnd))\2:Font 2
Randomize:var col&=rnd(8^8):usepen 0,1,16777215
set("decimals",16):var f!=pi()/180
declare x!,y!,z!,w!,a!,b!,c!,d!,sa!,sb!,sc!,ca!,cb!,cc!,sd!,cd!
declare p$,p$[],p![], n&,i&,k0&,x0!,y0!,z0!,w0!,u0!,v0!,eye!
declare k$,k$[],k&[],m&,j&,k1&,x1!,y1!,z1!,w1!,u1!,v1!,zoom!,cs!
'  4D-Eckpunkte x!,y!,z!,v!
'                       0              1                  2                     3                      4               5                    6                7
p$=        "-1,-1,-1,-1 ,  -1,-1, 1,-1,  -1, 1,-1,-1  ,   -1, 1, 1,-1 ,  1,-1,-1,-1  ,  1,-1, 1,-1  ,  1, 1,-1,-1  ,  1, 1, 1,-1"
'                       8              9                  10                     11                 12              13                 14               15
p$=p$+", -1,-1,-1,1  ,  -1,-1, 1,1,    -1, 1,-1,1  ,   -1, 1, 1,1,     1,-1,-1,1   ,   1,-1,1,1    ,  1, 1,-1, 1,     1, 1, 1,1"
'  Kanten From-point To-point
'                 0        1         2         3         4         5         6          7         8        9       10      11
k$=        "0,1  ,  1,3   ,  3,2  ,   2,0   ,  4,5  ,  5,7  ,  7,6   , 6,4  ,   1,5  ,  0,4  ,  2,6  ,   3,7 "
'                12      13       14        15       16       17       18       19       20      21       22        23
k$=k$+", 8,9 ,   9,11,  11,10, 10,8, 12,13, 13,15, 15,14, 14,12,  9,13,  8,12,  10,14,  11,15"
'                 24     25       26        27       28        29        30       31
k$=k$+", 0,8 ,   1,9   ,  3,11 ,  2,10 ,  4,12 ,   5,13 ,  7,15 ,  6,14"
p$[]=explode(p$,","):n&=sizeof(p$[]):clear p![]
setsize p![],n&:p![]=val(p$[&index]):clear p$[]
k$[]=explode(k$,",") :m&=sizeof(k$[]):clear k&[]
setsize k&[],m&:k&[]=val(k$[&index]):clear k$[]
Declare Bitmap%

WHILELOOP 0,360 * 20' Umdrehungen

    Case Bitmap% : DeleteObject Bitmap%
    Bitmap% = create("hNewPic", %maxx,%maxy,col&)
    StartPaint Bitmap%
    Text Color rgb(255,0,0),-1
    DrawText 1,1,"Ende ESC"
    line 0,ym& - 2*xm&,ym&:line xm&,2*ym& - xm&,0
    eye!=40
    cs!=cos(&Loop*f!)
    zoom!=5*width(%HWnd)*(cs!*cs!+0.3)
    a!=f!*&LOOP/2
    b!=f!*(10+&LOOP)/2
    c!=f!*(20+&LOOP)' strain
    d!=f!*&LOOP
    ' for any Kanten:

    whileLoop 0,(m&-1)\2 : j&=2*&Loop

        k0&=4*k&[j&] : k1&=4*k&[j&+1]
        x!=p![k0&] : y!=p![k0&+1] : z!=p![k0&+2] : w!=p![k0&+3]
        rotate a!,b!,c!,d!  : x0!=x! : y0!=y! : z0!=z! : w0!=w!
        u0!=zoom!*w0!*x0! / (z0!-eye!) : v0!=zoom!*y0!*w0! / (z0!-eye!)
        x!=p![k1&] : y!=p![k1&+1] : z!=p![k1&+2] : w!=p![k1&+3]
        rotate a!,b!,c!,d! : x1!=x! : y1!=y! : z1!=z! : w1!=w!
        u1!=zoom!*w1!*x1! / (z1!-eye!) : v1!=zoom!*w1!*y1! / (z1!-eye!)
        usepen 0,10,rgb(240,240,240)
        line xm&+u0!,(ym&-v0!) - (xm&+u1!),ym&-v1!
        drawtext xm&+u0!,ym&-v0!,st$(k0&\3)
        drawtext xm&+u1!,ym&-v1!,st$(k1&\3)

    endwhile

    Endpaint
    DrawPic Bitmap%, 0, 0; 0
    WaitInput 1
    Case %Key=27:BREAK

ENDWHILE

DeleteObject Bitmap%
WaitInput
END

proc rotate

    parameters a!,b!,c!,d!
    declare xx!,yy!,zz!,ww!
    sa!=sin(a!):sb!=sin(b!):sc!=sin(c!):sd!=sin(d!)
    ca!=cos(a!):cb!=cos(b!):cc!=cos(c!):cd!=cos(d!)
    xx!=x!*ca!+y!*sa!
    yy!=x!*sa!-y!*ca!
    zz!=z!
    ww!=w!
    x!=xx!
    y!=yy!*cb!+zz!*sb!
    z!=yy!*sb! -zz!*cb!
    w!=ww!
    xx!=x!*cc!+z!*sc!
    yy!=y!
    zz!=x!*sc!-z!*cc!
    ww!=w!
    x!=xx!
    y!=yy!
    z!=zz!*cos(d!) + ww!*sin(d!)
    w!=abs(zz!*sin(d!) - ww!*cos(d!))
    'w!=w!*w!

endproc