From 0bd2ef581c19d6e015b568797d22810e345cf6a8 Mon Sep 17 00:00:00 2001
From: TQ Hirsch <thequux@thequux.com>
Date: Mon, 30 Jan 2023 23:44:54 +0100
Subject: [PATCH] Semi-successful optimization run. Unfortunately, I just got
 screwed by my choice of RoC rather than curvature, which means that
 optimization won't invert a surface

---
 app/Main.hs                 | 25 +++++++++++++++----------
 lib/Petzval/Merit.hs        |  4 ++--
 lib/Petzval/Optimization.hs | 12 ++++++++++++
 3 files changed, 29 insertions(+), 12 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index 87edb4d..56c1f8c 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -15,9 +15,11 @@ import Petzval.Calculations
 import Petzval.Optimization
 import Petzval.Types
 import System.Environment (getArgs)
+import System.IO (hPrint, stderr)
 import Linear
 import Numeric.AD.Mode (Scalar, Mode)
 import qualified Numeric.LinearAlgebra as L
+import qualified Data.List as DL
 
 bk7 = SellemeierMat [ (1.03961212,  6.00069867e-3 )
                     , (0.231792344, 2.00179144e-2 )
@@ -69,30 +71,33 @@ type Id a = a -> a
 
 
 doOptimize steps = runWriterT $ optimizeDLS cfg vars merit system1
-    where merit = mkMerit [ DynMerit $ TW 50 100 $ BFL Nothing
+    where merit = mkMerit [ DynMerit $ TW 100 100 $ BFL Nothing
                           , DynMerit $ TW 0 1 $ SpotSize Nothing
+                          , DynMerit $ TW 0 1 $ SpotSize (Just $ TraceConditions 7 0.587618)
+                          , DynMerit $ TW 0 1 $ SpotSize (Just $ TraceConditions 15 0.587618)
                           ]
           vars :: VariableSet
-          vars = (ix 1 . roc) `adjoin` (ix 2 . roc)
-          vars2 = undefined -- foldl1 adjoin
-                  -- [ ix 1.roc , ix 2.roc]
-          cfg = def{maxSteps = steps}
+          vars = (ix 1 . roc) `adjoin` (ix 2 . roc) `adjoin` (ix 2.thickness)
+          cfg = def{maxSteps = steps,eps1=0,eps2=0}
 
               
 
 main :: IO ()
 main =
-  let baked = bake 0.587618 system2
+  let baked = bake 0.587618 system2 :: [Element BakedIOR Double]
       ep = (entrancePupil baked){position=20.4747094540}
       fa = 20
   in do
     [arg] <- getArgs
     let steps = read arg
     print $ L.norm_2  (L.fromList [3.0 , 4.0] :: L.Vector Double)
-    doOptimize steps >>= print
-    putStrLn $ show ep
-    putStrLn $ show $ rearFocalLength $ lensRTM baked
-    putStrLn $ show $ mconcat (seidel ep fa baked :: [Seidel Double])
+    (result, tr) <- doOptimize steps
+    hPrint stderr result
+    putStrLn "---"
+    mapM_ (putStrLn . DL.intercalate "," . map show) tr
+    -- putStrLn $ show ep
+    --putStrLn $ show $ rearFocalLength $ lensRTM baked
+    --putStrLn $ show $ mconcat (seidel ep fa baked :: [Seidel Double])
     
  {-   defaultMain [
       bgroup "merit" [ bench "system1" $ nf merit (system1 :: [Element SellemeierMat Double])
diff --git a/lib/Petzval/Merit.hs b/lib/Petzval/Merit.hs
index 5fd6414..5669d9c 100644
--- a/lib/Petzval/Merit.hs
+++ b/lib/Petzval/Merit.hs
@@ -1,5 +1,5 @@
 {- LANGUAGE ImpredicativeTypes #-}
-module Petzval.Merit (BFL(..), SpotSize(..), DynMerit(..), TW(..), Merit(..), MeritFunction, evalMerit, mkMerit) where
+module Petzval.Merit (BFL(..), SpotSize(..), DynMerit(..), TW(..), Merit(..), MeritFunction, TraceConditions(..), evalMerit, mkMerit) where
 
 import Petzval.Calculations
 import Petzval.Types
@@ -66,7 +66,7 @@ spotSize' conditions ts = rmsSize
                              . map fst
                              . map (raytrace system)
                              . map (createRay Nothing ep fa)
-                             $ hexapolarPattern 10
+                             $ hexapolarPattern 6
     where
       system = systemAtWavelength (wavelength conditions) ts
       fa = auto $ fieldAngle conditions
diff --git a/lib/Petzval/Optimization.hs b/lib/Petzval/Optimization.hs
index 7591b4e..1020d21 100644
--- a/lib/Petzval/Optimization.hs
+++ b/lib/Petzval/Optimization.hs
@@ -19,6 +19,7 @@ import Petzval.Optics
 import Petzval.Types
 import Control.Monad.Writer.Class
 import Data.Default
+import qualified Data.List as L
 
 import Debug.Trace
 
@@ -129,6 +130,17 @@ optimizeDLS cfg vars merit system = fmap (setVars vars system . toList) $ evalSt
       tell [toList y]
       
       return $ newMerit - oldMerit
+    jacobian' :: ([Double] -> [Double]) -> [Double] -> [(Double, [Double])]
+    jacobian' fn vars = zip (fn vars) jacobian
+        where deltas = map (/1000) vars
+              jacobian = L.transpose $ varSets vars id
+              varSets :: [Double] -> ([Double] -> [Double]) -> [[Double]]
+              varSets [] _ = []
+              varSets (var:vars) varPfx = head : rest
+                  where fnWithD d = fn . varPfx $ var + d : vars
+                        delta = var / 1000
+                        head = map (/ (2 * delta)) $ zipWith (-) (fnWithD delta) (fnWithD (-delta))
+                        rest = varSets vars (varPfx . (var:))
     jacobianAt :: Vector Double -> (Vector Double, Matrix Double)
     jacobianAt pt = let eval pt = undefined
                         (y,a) = unzip . jacobian' (\adpt -> evalMerit merit $ setVars vars (system & each.liftFp %~ auto) adpt) $ toList pt