'===========================================================================
' Subject: MOVING LIGHTS STAIRS UP           Date: 03-17-99 (13:15)       
' Author:  Jacob Wieles                      Code: QB, QBasic, PDS, PB    
' Origin:  jacwls@worldonline.nl           Packet: GRAPHICS.ABC
'===========================================================================
'program        : MOTION-4.BAS  (16-03-99)
'                 Playing with a look-a-like Penrose & Penrose stairs
'                 and simulation of moving lights stairs up with data
'                 change in the DAC (Digital Analog Converter)
'which basic    : PowerBASIC and Q(uick)BASIC
'auteur         : Jacob Wieles

defint a-z
ix=8
iy=4
x1=ix:x2=2*ix:x3=3*ix:x4=4*ix:x5=5*ix
y1=iy:y2=2*iy:y3=3*iy:y4=4*iy:y5=5*iy:y6=6*iy:y8=8*iy
pxst=320+5*x2
pyst=240-2*y4
gosub initdrawstrings
screen 12
gosub initialcolor
color 1
gosub Stairs
call HitKey("Walls")
gosub Walls
call HitKey("Briks")
gosub Briks
call HitKey("Go up")
gosub simulation
gosub MakeColorsLight
while inkey$<>"":wend
locate 1,1
print" Hit a key for end.                      "
hitakey$=input$(1)
einde:
cls
screen 0
w!=timer
while timer<w!+1:wend
print" Thank you for running this program. Hit a key for the source."
end
'=======================================================================
Stairs:
  px=pxst
  py=pyst
  for i=0 to 23
    select case i
    case 0
    pset(px,py),1
    draw f1$
    paint(px,py-2),7-i mod 6,1      'top
    paint(px-1,py+1),9,1            'left
    paint(px+1,py+1),8,1            'right
    case 1 to 9
      px=px-x4
      py=py-y2
      pset(px,py),1
      draw f2$
      paint(px-1,py-2),7-i mod 6,1  'top
      paint(px-1,py+1),9,1          'left
    case 10 to 17
      px=px+x4
      py=py-y2
      if i=10 then
        pset(px,py),10
        draw f3$
        paint(px,py-y6),7-i mod 6,1 'top
        paint(px+x3,py-y2),8,1      'right
      end if
      if i=11 then
        pset(px,py),1
        draw f4$
        paint(px,py-y6),7-i mod 6,1 'top
        paint(px+2,py),8,1          'right
      end if
      if i>11 then
        pset(px,py),1
        draw f5$
        paint(px,py-y6),7-i mod 6,1 'top
        paint(px+2,py),8,1          'right
      end if
    case 18
      px=px+x4
      py=py-y2
      pset(px,py),1
      draw f6$
      paint(px,py-y6),7-i mod 6,1   'top
      paint(px+2,py),8,1            'right
    case 19,20
      px=px+x4
      py=py+y6
      pset(px,py),1
      draw f7$
      paint(px,py-2),7-i mod 6,1    'top
      paint(px-2,py),9,1            'left
      paint(px+2,py),8,1            'right
    case 21
      px=px+x4
      py=py+y6
      pset(px,py),1
      draw f8$
      paint(px,py-2),7-i mod 6,1    'top
      paint(px-1,py+1),9,1          'left
      paint(px+1,py+1),8,1          'right
    case 22,23
      px=px-x4
      py=py+y6
      pset(px,py),1
      draw f8$
      paint(px,py-2),7-i mod 6,1    'top
      paint(px-1,py+1),9,1          'left
      paint(px+1,py+1),8,1          'right
    end select
  next i
return

Walls:
px=pxst+4*x4
py=pyst-9*y2
pset(px,py)
line-step(0,27*y2),1
line-step(-4*x4,4*y4),1
du=12*y4
draw"c1nu="+varptr$(du)
line-step(-10*x4,-10*y4),1
line-step(0,-15*y2),1
paint(point(0)+x1,point(1)+y2),9,1
paint(px-x4,py+2*y4),8,1
px=pxst
py=pyst
line(px,py-5*y2)-(px,py-15*y2),1
paint(px-x2,py-7*y2),8,1
paint(px+x2,py-7*y2),9,1
paint(px-5*x5,py-10*y2),8,1
'==================================
px=pxst+4*x4
py=pyst+7*y4
pset(px,py)
line-step(2*x4,2*y4),1
line-step(-6*x4,6*y4),1
line-step(-12*x4,-12*y4),1
line-step(2*x4,-2*y4),1
paint(px+x2,py+y4),10,1
return

Briks:
px=pxst+4*x4
py=pyst-9*y2
for i=1 to 3
  pset(px-i*x4,py+i*y6)
  line-step(0,27*y2-i*y2),1
next i
for i=0 to 3
  pyw=py+i*y6
  for j=1 to 13-i/2
    pset(px-i*x4,pyw+j*y4)
    line-step(-x4,y4),1
  next j
next i
'=================================
px=pxst
py=pyst+y4
for i=1 to 9
  pset(px-i*x4,py-i*y2)
  line-step(0,24*y2-i*y2),1
next i
for i=0 to 9
  if i=0 or i=1 then k=0
  if i=2 or i=3 then k=1
  if i=4 or i=5 then k=2
  if i=6 or i=7 then k=3
  if i=8 or i=9 then k=4
  pyw=py-i*y2
  for j=1 to 11-k
    pset(px-i*x4,pyw+j*y4)
    line-step(-x4,-y4),1
  next j
next i
'=====================================
px=pxst-6*x4
py=pyst-5*y4
for i=1 to 5
  pset(px+i*x4,py-i*y2)
  line-step(0,i*y4),1
next i
for i=0 to 5
  k=0
  for j=1+i to 6
    pset(px+j*x4,py+i*y4-(j-1)*y2)
    if k=0 then
      line-step(-x2,y2),1
    else
      line-step(-x4,y4),1
    end if
    k=1
  next j
next i

px=pxst
py=pyst-13*y2
pset(px+x4,py+y2)
line-step(0,2*y4),1
pset(px+x4,py+y6)
line-step(x2,y2),1
for i=0 to 3
  pset(px,py+i*y4)
  if i<3 then
    line-step(x4,y4),1
  else
    line-step(x2,y2),1
  end if
next i
return


initialcolor:
  call NewPaletteUsing        '===>>>  PB  set AC (0-15) to (0-15)
  call SetColor(0,0,0,1)      'Color 1: Black
  call SetColor(63,63,63,0)   'Background color White
  call SetColor(63,0,0,8)     'DAC (8) color Light red
  call SetColor(0,0,63,9)     'DAC (9) color Light blue
  call SetColor(0,63,0,10)    'DAC (10) color Light green
  call SetColor(0,50,0,11)    'DAC (16) color Green

  for i=2 to 7                '6 x paint-color for top >> Green
    call ChangeColor(11,i)    'color 2-7
  next i
return

MakeColorslight:
  for i=2 to 7
    call ChangeColor(10,i)
  next i
return

simulation:
dt!=.2   ' try an other value
do
  locate 1,1
  print" Hit spacebar for stop.";
  print"            "
  do
    for i=0 to 5
      call ChangeColor(10,2+i)            ' Make the color light
      call ChangeColor(11,7-(6-i) mod 6)  ' Make the color dark
      t!=timer
      while timer<t!+dt!:wend
    next i
  loop until inkey$=chr$(32)
  locate 1,1
  print" Go on with Enter.";
  print"  Stop with Esc."
  do
    hitakey=asc(input$(1))
  loop until hitakey=27 or hitakey=13
loop while hitakey=13
return

'============================================================
sub HitKey(HK$)
  while inkey$<>"":wend
  locate 1,1
  print" Hit Key for ";
  print HK$;
  hit$=input$(1)
  locate 1,1
  print"             ";
  print space$(len(hk$))
end sub


sub ChangeColor(col1,col2)    'R, G and B value from Dac (col1)
  out &H3C7,col1              'to DAC (col2)
  R=inp(&H3C9)
  G=inp(&H3C9)
  B=inp(&H3C9)
  out &H3C8,col2
  out &H3C9,R
  out &H3C9,G
  out &H3C9,B
end sub

sub SetColor(R,G,B,Dac)       'New R, G and B value to DAC (Dac)
  out &H3C8,Dac
  out &H3C9,R
  out &H3C9,G
  out &H3C9,B
end sub

sub NewPaletteUsing
  restore acdata
  dummy=inp(&H3DA)
  for attr=0 to 15
    out &H3C0,attr
    read col
    out &H3C0,col
  next attr
  out &H3C0,32
end sub


initdrawstrings:
'=======================================================================
  f1$="C1BU="+VARPTR$(y8)+"M+="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f1$=f1$+"D="+VARPTR$(y4)+"M-="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f1$=f1$+"M-="+VARPTR$(x4)+",-="+VARPTR$(y4)+"U="+VARPTR$(y4)
  f1$=f1$+"M+="+VARPTR$(x4)+",-="+VARPTR$(y4)+"BD="+VARPTR$(y8)
  f1$=f1$+"NM-="+VARPTR$(x4)+",-="+VARPTR$(y4)
  f1$=f1$+"NM+="+VARPTR$(x4)+",-="+VARPTR$(y4)+"ND="+VARPTR$(y4)
'=======================================================================
  f2$="C1BU="+VARPTR$(y8)+"M+="+VARPTR$(x3)+",+="+VARPTR$(y3)
  f2$=f2$+"M-="+VARPTR$(x3)+",+="+VARPTR$(y3)
  f2$=f2$+"D="+VARPTR$(y6)
  f2$=f2$+"M-="+VARPTR$(x4)+",-="+VARPTR$(y4)+"U="+VARPTR$(y4)
  f2$=f2$+"M+="+VARPTR$(x4)+",-="+VARPTR$(y4)+"BD="+VARPTR$(y8)
  f2$=f2$+"NM-="+VARPTR$(x4)+",-="+VARPTR$(y4)
  f2$=f2$+"ND="+VARPTR$(y4)
'=======================================================================
  f3$="C1BU="+VARPTR$(y8)+"M+="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f3$=f3$+"D="+VARPTR$(y2)+"M-="+VARPTR$(x1)+",+="+VARPTR$(y1)
  f3$=f3$+"M-="+VARPTR$(x1)+",-="+VARPTR$(y1)
  f3$=f3$+"NM+="+VARPTR$(x2)+",-="+VARPTR$(y2)
  f3$=f3$+"M-="+VARPTR$(x2)+",-="+VARPTR$(y2)
  f3$=f3$+"M-="+VARPTR$(x1)+",+="+VARPTR$(y1)
  f3$=f3$+"M-="+VARPTR$(x2)+",-="+VARPTR$(y2)
  f3$=f3$+"M+="+VARPTR$(x3)+",-="+VARPTR$(y3)+"BD="+VARPTR$(y8)
'========================================================================
  f4$="C1BU="+VARPTR$(y8)+"M+="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f4$=f4$+"D="+VARPTR$(y4)+"M-="+VARPTR$(x2)+",+="+VARPTR$(y2)
  f4$=f4$+"M-="+VARPTR$(x2)+",-="+VARPTR$(y2)+"U="+VARPTR$(y2)
  f4$=f4$+"M-="+VARPTR$(x3)+",-="+VARPTR$(y3)
  f4$=f4$+"M+="+VARPTR$(x3)+",-="+VARPTR$(y3)+"BD="+VARPTR$(y8)
  f4$=f4$+"NM+="+VARPTR$(x4)+",-="+VARPTR$(y4)
'========================================================================
  f5$="C1BU="+VARPTR$(y8)+"M+="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f5$=f5$+"D="+VARPTR$(y4)+"M-="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f5$=f5$+"U="+VARPTR$(y6)
  f5$=f5$+"M-="+VARPTR$(x3)+",-="+VARPTR$(y3)
  f5$=f5$+"M+="+VARPTR$(x3)+",-="+VARPTR$(y3)+"BD="+VARPTR$(y8)
  f5$=f5$+"NM+="+VARPTR$(x4)+",-="+VARPTR$(y4)+"ND="+VARPTR$(y4)
'========================================================================
  f6$="C1BU="+VARPTR$(y8)+"M+="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f6$=f6$+"D="+VARPTR$(y2)+"M-="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f6$=f6$+"U="+VARPTR$(y4)+"M-="+VARPTR$(x3)+",-="+VARPTR$(y3)
  f6$=f6$+"M+="+VARPTR$(x3)+",-="+VARPTR$(y3)+"BD="+VARPTR$(y8)
  f6$=f6$+"NM+="+VARPTR$(x4)+",-="+VARPTR$(y4)
'========================================================================
  f7$="C1BU="+VARPTR$(y8)+"M+="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f7$=f7$+"D="+VARPTR$(y2)+"M-="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f7$=f7$+"D="+VARPTR$(y2)+"M-="+VARPTR$(x4)+",-="+VARPTR$(y4)
  f7$=f7$+"U="+VARPTR$(y4)
  f7$=f7$+"M+="+VARPTR$(x4)+",-="+VARPTR$(y4)+"BD="+VARPTR$(y8)
  f7$=f7$+"NM-="+VARPTR$(x4)+",-="+VARPTR$(y4)
  f7$=f7$+"NM+="+VARPTR$(x4)+",-="+VARPTR$(y4)+"ND="+VARPTR$(y2)
'========================================================================
  f8$="C1BU="+VARPTR$(y8)+"M+="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f8$=f8$+"D="+VARPTR$(y4)+"M-="+VARPTR$(x4)+",+="+VARPTR$(y4)
  f8$=f8$+"U="+VARPTR$(y2)+"M-="+VARPTR$(x4)+",-="+VARPTR$(y4)
  f8$=f8$+"U="+VARPTR$(y2)
  f8$=f8$+"M+="+VARPTR$(x4)+",-="+VARPTR$(y4)+"BD="+VARPTR$(y8)
  f8$=f8$+"NM-="+VARPTR$(x4)+",-="+VARPTR$(y4)
  f8$=f8$+"NM+="+VARPTR$(x4)+",-="+VARPTR$(y4)+"ND="+VARPTR$(y2)
'========================================================================
return

acdata:
data 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15