Sorceress

Lensing

Apr 5th, 2020
181
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. 'Lensing by @_sorceress in April 2020
  2. 'Run in QB64
  3. '-------------------------------------------------------
  4.  
  5. CurvatureLeft = 10
  6. CurvatureRight = 10
  7. LensThickness = 2
  8.  
  9. SCREEN 13
  10. PRINT "use numeric pad to change lens"
  11. SLEEP
  12.  
  13. DO
  14.   k$ = INKEY$
  15.   IF k$ = "1" THEN CurvatureLeft = CurvatureLeft + .5
  16.   IF k$ = "4" THEN CurvatureLeft = CurvatureLeft - .5
  17.   IF k$ = "2" THEN LensThickness = LensThickness + .5
  18.   IF k$ = "5" THEN LensThickness = LensThickness - .5: IF LensThickness < 0 THEN LensThickness = 0
  19.   IF k$ = "3" THEN CurvatureRight = CurvatureRight + .5
  20.   IF k$ = "6" THEN CurvatureRight = CurvatureRight - .5
  21.  
  22.   'clear
  23.   CLS
  24.  
  25.   'draw lens
  26.   LINE (0, 100)-(320, 100), 8
  27.   FOR t = -1 TO 1 STEP .01
  28.     GOSUB getLens
  29.     LINE (xL, y)-(xR, y), 11
  30.   NEXT
  31.  
  32.   'draw ray
  33.   sy = sy + 1: IF sy >= 200 THEN sy = sy - 200
  34.  
  35.   FOR col = 40 TO 55 STEP .5 'rainbow
  36.     ok = 0: oldinLens = 0
  37.     rayX = 0: rayY = sy: rayA = 0
  38.     PSET (rayX, rayY)
  39.     eta = 1.5 + .08 * (col - 40) / 15 '1.50 to 1.58 for glass
  40.     FOR i = 0 TO 400
  41.       oldinLens = inLens
  42.       rayX = rayX + COS(rayA)
  43.       rayY = rayY + SIN(rayA)
  44.       t = (rayY - 100) / 50: GOSUB getLens
  45.       IF rayX > xL AND rayX < xR AND ABS(t) < 1 THEN inLens = 1 ELSE inLens = 0
  46.       dLens = inLens - oldinLens
  47.       IF dLens <> 0 THEN 'lens transition
  48.         IF dLens > 0 THEN e = 1 / eta 'air to glass
  49.         IF dLens < 0 THEN e = eta 'glass to air
  50.         ok = 1
  51.         t = (rayY - 100) / 50
  52.         GOSUB getLens
  53.         IF ABS(rayX - xL) < ABS(rayX - xR) THEN nA = ATN2(nyL, nxL) ELSE nA = ATN2(nyR, nxR)
  54.         IF dLens = -1 THEN nA = nA + _PI
  55.         g = SIN(rayA - nA) * e
  56.         IF ABS(g) < 1 THEN
  57.           g = g / SQR(1 - g * g): rayA = ATN(g) + nA 'refraction!
  58.         ELSE
  59.           rayA = 2 * nA - rayA 'reflection!
  60.         END IF
  61.       END IF
  62.       IF ok = 1 THEN c = col ELSE c = 15
  63.       LINE -(rayX, rayY), c
  64.     NEXT
  65.   NEXT
  66.  
  67.   _DISPLAY
  68.   _LIMIT 60
  69.  
  70. LOOP
  71. END
  72.  
  73. getLens:
  74. y = 100 + 50 * t
  75. xL = 80 - LensThickness - (1 - t * t) * CurvatureLeft
  76. xR = 80 + LensThickness + (1 - t * t) * CurvatureRight
  77. nxL = 50: nyL = -2 * t * CurvatureLeft
  78. nxR = -50: nyR = -2 * t * CurvatureRight
  79. RETURN
  80.  
  81. FUNCTION ATN2 (dy, dx)
  82.   IF dx <> 0 THEN
  83.     ATN2 = ATN(dy / dx)
  84.     IF dx < 0 THEN
  85.       IF dy >= 0 THEN ATN2 = ATN2 + _PI ELSE ATN2 = ATN2 - _PI
  86.     END IF
  87.   ELSE
  88.     ATN2 = SGN(dy) * _PI / 2
  89.   END IF
  90. END FUNCTION
RAW Paste Data