Advertisement
autid

AoC 2019 Day10 FORTRAN

Dec 10th, 2019
2,104
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. PROGRAM DAY10
  2.   INTEGER :: I,J,K,IERR,NROWS,NCOLS,NOBJS,LASER,LASERLOC(2),PART2(2),DESTROYED
  3.   CHARACTER(LEN=1) :: CHAR
  4.   CHARACTER(LEN=1),ALLOCATABLE :: MAP(:,:)
  5.   CHARACTER(LEN=:),ALLOCATABLE :: LINE
  6.   INTEGER, ALLOCATABLE :: LOCATIONS(:,:),ORDER(:)
  7.   REAL,ALLOCATABLE :: DIRECTIONS(:)
  8.   LOGICAL, ALLOCATABLE :: SEEN(:,:),SHOT(:)
  9.   INTEGER :: HOURS_OF_WASTED_TIME(2)
  10.  
  11.   OPEN(1,FILE="input.txt")
  12.   NCOLS=0
  13.   DO
  14.      READ(1,'(A)',ADVANCE="NO",IOSTAT=IERR)CHAR
  15.      IF(IERR.NE.0)EXIT
  16.      NCOLS=NCOLS+1
  17.   END DO
  18.   REWIND(1)
  19.   NROWS=0
  20.   DO
  21.      READ(1,*,IOSTAT=IERR)
  22.      IF(IERR.NE.0)EXIT
  23.      NROWS=NROWS+1
  24.   END DO
  25.   REWIND(1)
  26.   ALLOCATE(CHARACTER(LEN=NCOLS) :: LINE)
  27.   ALLOCATE(MAP(NCOLS,NROWS))
  28.   DO I=1,NROWS
  29.      READ(1,*)LINE
  30.      DO J=1,NCOLS
  31.         MAP(J,I)=LINE(J:J)
  32.      END DO
  33.   END DO
  34.   CLOSE(1)
  35.   NOBJS=COUNT(MAP.EQ."#")
  36.   ALLOCATE(LOCATIONS(2,NOBJS),SEEN(NOBJS,NOBJS))
  37.   K=1
  38.   DO J=1,NROWS
  39.      DO I=1,NROWS
  40.         IF(MAP(I,J).EQ."#")THEN
  41.            LOCATIONS(:,K)=(/I,J/)
  42.            K=K+1
  43.         END IF
  44.      END DO
  45.   END DO
  46.  
  47.   SEEN=.FALSE.
  48.   DO I=1,NOBJS-1
  49.      DO J=I+1,NOBJS
  50.         SEEN(I,J)=CANSEE(LOCATIONS(:,I),LOCATIONS(:,J))
  51.         SEEN(J,I)=SEEN(I,J)
  52.      END DO
  53.   END DO
  54.   WRITE(*,'("Part 1: ",I0)') MAXVAL((/(COUNT(SEEN(:,I)),I=1,NOBJS)/))
  55.   LASER=MAXLOC((/(COUNT(SEEN(:,I)),I=1,NOBJS)/),DIM=1)
  56.   LASERLOC=LOCATIONS(:,LASER)
  57.   ALLOCATE(DIRECTIONS(NOBJS),SHOT(NOBJS),ORDER(NOBJS))
  58.  
  59.   SHOT=.FALSE.
  60.   SHOT(LASER)=.TRUE.
  61.   DO I=1,NOBJS
  62.      IF(I.EQ.LASER)CYCLE
  63.      DIRECTIONS(I)=GETDIR(LASERLOC,LOCATIONS(:,I))
  64.   END DO
  65.   ORDER=SORTORDER(DIRECTIONS)
  66.   DESTROYED=0
  67.   OUTER:DO
  68.      DO I=1,NOBJS
  69.         IF(SHOT(ORDER(I)))CYCLE
  70.         IF(CANSEE(LASERLOC,LOCATIONS(:,ORDER(I))))THEN
  71.            SHOT(ORDER(I))=.TRUE.
  72.            DESTROYED=DESTROYED+1
  73.            IF(DESTROYED.EQ.200)THEN
  74.               PART2=LOCATIONS(:,ORDER(I))
  75.               EXIT OUTER
  76.            END IF
  77.         END IF
  78.      END DO
  79.      DO I=1,NOBJS
  80.         IF(SHOT(ORDER(I)))THEN
  81.            MAP(LOCATIONS(1,ORDER(I)),LOCATIONS(2,ORDER(I)))="X"
  82.         END IF
  83.      END DO
  84.   END DO OUTER
  85.  
  86.   HOURS_OF_WASTED_TIME = (/-1,-1/)
  87.   WRITE(*,'("Part 2: ",I0,I2.2)')PART2+HOURS_OF_WASTED_TIME
  88.  
  89. CONTAINS
  90.   FUNCTION GETDIR(LOC1,LOC2) RESULT(RES)
  91.     INTEGER :: LOC1(2),LOC2(2)
  92.     REAL :: RES
  93.     RES= ATAN2(REAL(LOC2(1)-LOC1(1)),REAL(LOC1(2)-LOC2(2)))
  94.     IF(RES.LT.0)RES=RES+8*ATAN(1.0)
  95.   END FUNCTION GETDIR
  96.  
  97.   FUNCTION SORTORDER(ARRAY) RESULT(ORDER)
  98.     REAL :: ARRAY(:),NEXT
  99.     INTEGER :: ORDER(SIZE(ARRAY,DIM=1)),I,J
  100.     J=1
  101.     NEXT=MINVAL(ARRAY)-1
  102.     DO
  103.        IF(J>SIZE(ARRAY))EXIT
  104.        NEXT=MINVAL(ARRAY,MASK=ARRAY.GT.NEXT)
  105.        DO I=1,SIZE(ARRAY)
  106.           IF(ARRAY(I).EQ.NEXT)THEN
  107.              ORDER(J)=I
  108.              J=J+1
  109.           END IF
  110.        END DO
  111.     END DO
  112.   END FUNCTION SORTORDER
  113.  
  114.   FUNCTION CANSEE(LOC1,LOC2) RESULT(RES)
  115.     INTEGER :: LOC1(2),LOC2(2)
  116.     LOGICAL :: RES
  117.     INTEGER X,Y,XDIR,YDIR,DIV
  118.     RES=.FALSE.
  119.     XDIR=LOC2(1)-LOC1(1)
  120.     YDIR=LOC2(2)-LOC1(2)
  121.     IF(XDIR.EQ.0)THEN
  122.        YDIR=ABS(YDIR)/YDIR
  123.     ELSEIF(YDIR.EQ.0)THEN
  124.        XDIR=ABS(XDIR)/XDIR
  125.     ELSE
  126.        DIV=LCD(ABS(XDIR),ABS(YDIR))
  127.        XDIR=XDIR/DIV
  128.        YDIR=YDIR/DIV
  129.     END IF
  130.     X=LOC1(1)+XDIR
  131.     Y=LOC1(2)+YDIR
  132.     DO
  133.        IF(MAP(X,Y).EQ."#")THEN
  134.           IF(ALL(LOC2.EQ.(/X,Y/)))RES=.TRUE.
  135.           EXIT
  136.        END IF
  137.        X=X+XDIR
  138.        Y=Y+YDIR
  139.     END DO
  140.   END FUNCTION CANSEE
  141.  
  142.   FUNCTION LCD(A,B) RESULT(RES)
  143.     INTEGER :: A,B,C,D,RES
  144.     C=A
  145.     D=B
  146.     DO
  147.        IF(C.EQ.D)EXIT
  148.        IF(C.GT.D)THEN
  149.           C=C-D
  150.        ELSE
  151.           D=D-C
  152.        END IF
  153.     END DO
  154.     RES=C
  155.   END FUNCTION LCD
  156.  
  157. END PROGRAM DAY10
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement